From 1f83aebb4d4ac0714d8aafca4267c5827bdec40d Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Fri, 20 Mar 2026 12:35:11 -0400 Subject: [PATCH 01/25] Integrate ffmt Fortran formatter into MFC Replace fprettify + indenter.py with ffmt (https://github.com/sbryngelson/ffmt), a fast, configurable Fortran formatter written in Rust. Integration: - toolchain/bootstrap/format.sh: single ffmt call replaces multi-pass fprettify + indenter.py loop - toolchain/pyproject.toml: replace fprettify dependency with ffmt - ffmt.toml: MFC formatting configuration - .gitignore: add .ffmt_cache/ - Remove toolchain/indenter.py Source formatting: - All .fpp/.f90 files reformatted with ffmt v0.2.0 - Unicode symbols replaced with LaTeX (sigma, pi, partial, etc.) - Operator spacing, keyword casing, declaration alignment - Named end statements, comment wrapping at 132 chars - Doxygen comment block re-wrapping Install: pip install ffmt Repo: https://github.com/sbryngelson/ffmt --- .gitignore | 1 + ffmt.toml | 17 + src/common/include/1dHardcodedIC.fpp | 16 +- src/common/include/2dHardcodedIC.fpp | 105 +- src/common/include/3dHardcodedIC.fpp | 43 +- src/common/include/ExtrusionHardcodedIC.fpp | 113 +- src/common/include/acc_macros.fpp | 4 +- src/common/include/macros.fpp | 28 +- src/common/include/omp_macros.fpp | 27 +- src/common/include/parallel_macros.fpp | 7 - src/common/m_boundary_common.fpp | 891 ++---- src/common/m_checker_common.fpp | 20 +- src/common/m_chemistry.fpp | 146 +- src/common/m_compile_specific.f90 | 54 +- src/common/m_constants.fpp | 83 +- src/common/m_delay_file_access.f90 | 15 +- src/common/m_derived_types.fpp | 297 +- src/common/m_finite_differences.fpp | 98 +- src/common/m_helper.fpp | 366 +-- src/common/m_helper_basic.fpp | 61 +- src/common/m_model.fpp | 497 ++- src/common/m_mpi_common.fpp | 882 ++--- src/common/m_nvtx.f90 | 44 +- src/common/m_phase_change.fpp | 403 +-- src/common/m_precision_select.f90 | 7 +- src/common/m_variables_conversion.fpp | 728 ++--- src/post_process/m_checker.fpp | 7 +- src/post_process/m_data_input.f90 | 264 +- src/post_process/m_data_output.fpp | 759 ++--- src/post_process/m_derived_variables.fpp | 541 +--- src/post_process/m_global_parameters.fpp | 312 +- src/post_process/m_mpi_proxy.fpp | 244 +- src/post_process/m_start_up.fpp | 364 +-- src/post_process/p_main.fpp | 21 +- src/pre_process/m_assign_variables.fpp | 307 +- src/pre_process/m_boundary_conditions.fpp | 71 +- src/pre_process/m_check_ib_patches.fpp | 226 +- src/pre_process/m_check_patches.fpp | 302 +- src/pre_process/m_checker.fpp | 6 +- src/pre_process/m_data_output.fpp | 299 +- src/pre_process/m_global_parameters.fpp | 289 +- src/pre_process/m_grid.f90 | 125 +- src/pre_process/m_icpp_patches.fpp | 743 ++--- src/pre_process/m_initial_condition.fpp | 81 +- src/pre_process/m_mpi_proxy.fpp | 13 +- src/pre_process/m_perturbation.fpp | 148 +- src/pre_process/m_simplex_noise.fpp | 149 +- src/pre_process/m_start_up.fpp | 338 +- src/pre_process/p_main.f90 | 9 +- src/simulation/include/inline_capillary.fpp | 3 - src/simulation/include/inline_riemann.fpp | 40 +- src/simulation/m_acoustic_src.fpp | 220 +- src/simulation/m_body_forces.fpp | 91 +- src/simulation/m_bubbles.fpp | 705 ++-- src/simulation/m_bubbles_EE.fpp | 130 +- src/simulation/m_bubbles_EL.fpp | 762 ++--- src/simulation/m_bubbles_EL_kernels.fpp | 208 +- src/simulation/m_cbc.fpp | 890 ++---- src/simulation/m_checker.fpp | 37 +- src/simulation/m_compute_cbc.fpp | 104 +- src/simulation/m_compute_levelset.fpp | 283 +- src/simulation/m_data_output.fpp | 1000 ++---- src/simulation/m_derived_variables.fpp | 337 +- src/simulation/m_fftw.fpp | 93 +- src/simulation/m_global_parameters.fpp | 481 ++- src/simulation/m_hyperelastic.fpp | 123 +- src/simulation/m_hypoelastic.fpp | 336 +- src/simulation/m_ib_patches.fpp | 531 ++-- src/simulation/m_ibm.fpp | 534 ++-- src/simulation/m_igr.fpp | 1897 +++++------ src/simulation/m_mpi_proxy.fpp | 34 +- src/simulation/m_muscl.fpp | 168 +- src/simulation/m_pressure_relaxation.fpp | 98 +- src/simulation/m_qbmm.fpp | 1083 +++---- src/simulation/m_rhs.fpp | 1136 +++---- src/simulation/m_riemann_solvers.fpp | 3176 ++++++++----------- src/simulation/m_sim_helpers.fpp | 130 +- src/simulation/m_start_up.fpp | 461 +-- src/simulation/m_surface_tension.fpp | 147 +- src/simulation/m_time_steppers.fpp | 390 +-- src/simulation/m_viscous.fpp | 813 ++--- src/simulation/m_weno.fpp | 1752 +++++----- src/simulation/p_main.fpp | 43 +- src/syscheck/syscheck.fpp | 4 - toolchain/bootstrap/format.sh | 57 +- toolchain/indenter.py | 83 - toolchain/pyproject.toml | 2 +- 87 files changed, 11330 insertions(+), 17623 deletions(-) create mode 100644 ffmt.toml delete mode 100644 toolchain/indenter.py diff --git a/.gitignore b/.gitignore index 664b6c3083..aba54411e1 100644 --- a/.gitignore +++ b/.gitignore @@ -113,3 +113,4 @@ benchmarks/*.png cce_*/ cce_*.log run_cce_*.sh +.ffmt_cache/ diff --git a/ffmt.toml b/ffmt.toml new file mode 100644 index 0000000000..0060131b17 --- /dev/null +++ b/ffmt.toml @@ -0,0 +1,17 @@ +# MFC Fortran formatting configuration +# These are the defaults — this file makes them explicit. + +indent-width = 4 +keyword-case = "lower" +normalize-keywords = true +indent-fypp = true + +[whitespace] +relational = true +logical = true +plusminus = true +multdiv = false +power = false +assignment = true +declaration = true +comma = true diff --git a/src/common/include/1dHardcodedIC.fpp b/src/common/include/1dHardcodedIC.fpp index 4359528a3f..311980c40e 100644 --- a/src/common/include/1dHardcodedIC.fpp +++ b/src/common/include/1dHardcodedIC.fpp @@ -13,23 +13,20 @@ ! magnetic field q_prim_vf(B_idx%end - 1)%sf(i, 0, 0) = 0.1_wp*sin(2._wp*pi*x_cc(i)) q_prim_vf(B_idx%end)%sf(i, 0, 0) = 0.1_wp*cos(2._wp*pi*x_cc(i)) - case (170) - ! This hardcoded case can be used to start a simulation with initial conditions given from a known 1D profile (e.g. Cantera, SDtoolbox) + ! This hardcoded case can be used to start a simulation with initial conditions given from a known 1D profile (e.g. Cantera, + ! SDtoolbox) @: HardcodedReadValues() - case (180) ! This is patch is hard-coded for test suite optimization used in the ! 1D_shuoser cases: "patch_icpp(2)%alpha_rho(1)": "1 + 0.2*sin(5*x)" if (patch_id == 2) then q_prim_vf(contxb + 0)%sf(i, 0, 0) = 1 + 0.2*sin(5*x_cc(i)) end if - case (181) ! This is patch is hard-coded for test suite optimization used in the ! 1D_titarevtorro cases: "patch_icpp(2)%alpha_rho(1)": "1 + 0.1*sin(20*x*pi)" q_prim_vf(contxb + 0)%sf(i, 0, 0) = 1 + 0.1*sin(20*x_cc(i)*pi) - case (182) ! This patch is a hard-coded for test suite optimization (multiple component diffusion) x_mid_diffu = 0.05_wp/2.0_wp @@ -51,16 +48,11 @@ temp = (320.0_wp - 1350.0_wp)*profile_shape + 1350.0_wp - molar_mass_inv = y1/31.998_wp + & - y2/18.01508_wp + & - y3/16.04256_wp + & - y4/28.0134_wp + molar_mass_inv = y1/31.998_wp + y2/18.01508_wp + y3/16.04256_wp + y4/28.0134_wp q_prim_vf(contxb)%sf(i, 0, 0) = 1.01325_wp*(10.0_wp)**5/(temp*8.3144626_wp*1000.0_wp*molar_mass_inv) - case default call s_int_to_str(patch_id, iStr) - call s_mpi_abort("Invalid hcid specified for patch "//trim(iStr)) + call s_mpi_abort("Invalid hcid specified for patch " // trim(iStr)) end select - #:enddef diff --git a/src/common/include/2dHardcodedIC.fpp b/src/common/include/2dHardcodedIC.fpp index a35633bca1..8354bb61b9 100644 --- a/src/common/include/2dHardcodedIC.fpp +++ b/src/common/include/2dHardcodedIC.fpp @@ -6,7 +6,6 @@ real(wp) :: factor real(wp) :: r0, alpha, r2 real(wp) :: sinA, cosA - real(wp) :: r_sq ! # 207 @@ -18,9 +17,7 @@ #:enddef #:def Hardcoded2D() - select case (patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case - case (200) if (y_cc(j) <= (-x_cc(i)**3 + 1)**(1._wp/3._wp)) then ! Volume Fractions @@ -107,11 +104,10 @@ pInt = pref + rhoH*9.81_wp*(1.2_wp - intH) q_prim_vf(E_idx)%sf(i, j, 0) = pInt + rhoL*9.81_wp*(intH - y_cc(j)) end if - case (205) ! 2D lung wave interaction problem - h = 0.0_wp !non dim origin y - lam = 1.0_wp !non dim lambda - amp = patch_icpp(patch_id)%a(2) !to be changed later! !non dim amplitude + h = 0.0_wp ! non dim origin y + lam = 1.0_wp ! non dim lambda + amp = patch_icpp(patch_id)%a(2) ! to be changed later! !non dim amplitude intH = amp*sin(2*pi*x_cc(i)/lam - pi/2) + h @@ -122,29 +118,25 @@ q_prim_vf(advxb)%sf(i, j, 0) = patch_icpp(1)%alpha(1) q_prim_vf(advxe)%sf(i, j, 0) = patch_icpp(1)%alpha(2) end if - case (206) ! 2D lung wave interaction problem - horizontal domain - h = 0.0_wp !non dim origin y - lam = 1.0_wp !non dim lambda + h = 0.0_wp ! non dim origin y + lam = 1.0_wp ! non dim lambda amp = patch_icpp(patch_id)%a(2) intL = amp*sin(2*pi*y_cc(j)/lam - pi/2) + h - if (x_cc(i) > intL) then !this is the liquid + if (x_cc(i) > intL) then ! this is the liquid q_prim_vf(contxb)%sf(i, j, 0) = patch_icpp(1)%alpha_rho(1) q_prim_vf(contxe)%sf(i, j, 0) = patch_icpp(1)%alpha_rho(2) q_prim_vf(E_idx)%sf(i, j, 0) = patch_icpp(1)%pres q_prim_vf(advxb)%sf(i, j, 0) = patch_icpp(1)%alpha(1) q_prim_vf(advxe)%sf(i, j, 0) = patch_icpp(1)%alpha(2) end if - case (207) ! Kelvin Helmholtz Instability sigma = 0.05_wp/sqrt(2.0_wp) gauss1 = exp(-(y_cc(j) - 0.75_wp)**2/(2.0_wp*sigma**2)) gauss2 = exp(-(y_cc(j) - 0.25_wp)**2/(2.0_wp*sigma**2)) - q_prim_vf(momxb + 1)%sf(i, j, 0) = & - 0.1_wp*sin(4.0_wp*pi*x_cc(i))*(gauss1 + gauss2) - + q_prim_vf(momxb + 1)%sf(i, j, 0) = 0.1_wp*sin(4.0_wp*pi*x_cc(i))*(gauss1 + gauss2) case (208) ! Richtmeyer Meshkov Instability lam = 1.0_wp eps = 1.0e-6_wp @@ -160,7 +152,6 @@ q_prim_vf(advxb)%sf(i, j, 0) = alpha_sf6 q_prim_vf(advxe)%sf(i, j, 0) = alpha_air end if - case (250) ! MHD Orszag-Tang vortex ! gamma = 5/3 ! rho = 25/(36*pi) @@ -173,12 +164,11 @@ q_prim_vf(B_idx%beg)%sf(i, j, 0) = -sin(2._wp*pi*y_cc(j))/sqrt(4._wp*pi) q_prim_vf(B_idx%beg + 1)%sf(i, j, 0) = sin(4._wp*pi*x_cc(i))/sqrt(4._wp*pi) - case (251) ! RMHD Cylindrical Blast Wave [Mignone, 2006: Section 4.3.1] if (x_cc(i)**2 + y_cc(j)**2 < 0.08_wp**2) then q_prim_vf(contxb)%sf(i, j, 0) = 0.01 q_prim_vf(E_idx)%sf(i, j, 0) = 1.0 - elseif (x_cc(i)**2 + y_cc(j)**2 <= 1._wp**2) then + else if (x_cc(i)**2 + y_cc(j)**2 <= 1._wp**2) then ! Linear interpolation between r=0.08 and r=1.0 factor = (1.0_wp - sqrt(x_cc(i)**2 + y_cc(j)**2))/(1.0_wp - 0.08_wp) q_prim_vf(contxb)%sf(i, j, 0) = 0.01_wp*factor + 1.e-4_wp*(1.0_wp - factor) @@ -223,7 +213,6 @@ q_prim_vf(momxb)%sf(i, j, 0) = -(2._wp/sqrt(r_sq))*(y_cc(j) - 0.5_wp)*(0.115_wp - sqrt(r_sq))/(0.015_wp) q_prim_vf(momxb + 1)%sf(i, j, 0) = (2._wp/sqrt(r_sq))*(x_cc(i) - 0.5_wp)*(0.115_wp - sqrt(r_sq))/(0.015_wp) end if - case (253) ! MHD Smooth Magnetic Vortex ! Section 5.2 of ! Implicit hybridized discontinuous Galerkin methods for compressible magnetohydrodynamics @@ -238,13 +227,13 @@ q_prim_vf(B_idx%beg + 1)%sf(i, j, 0) = x_cc(i)*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/(2.*pi) ! pressure - q_prim_vf(E_idx)%sf(i, j, 0) = 1._wp + (1 - 2._wp*(x_cc(i)**2 + y_cc(j)**2))*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/((2._wp*pi)**3) - - case (260) ! Gaussian Divergence Pulse - ! Bx(x) = 1 + C * erf((x-0.5)/σ) - ! ⇒ ∂Bx/∂x = C * (2/√π) * exp[-((x-0.5)/σ)**2] * (1/σ) - ! Choose C = ε * σ * √π / 2 ⇒ ∂Bx/∂x = ε * exp[-((x-0.5)/σ)**2] - ! ψ is initialized to zero everywhere. + q_prim_vf(E_idx)%sf(i, j, & + & 0) = 1._wp + (1 - 2._wp*(x_cc(i)**2 + y_cc(j)**2))*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/((2._wp*pi)**3) + case (260) ! Gaussian Divergence Pulse + ! Bx(x) = 1 + C * erf((x-0.5)/\sigma) + ! => \partialBx/\partialx = C * (2/\sqrt\pi) * exp[-((x-0.5)/\sigma)**2] * (1/\sigma) + ! Choose C = \epsilon * \sigma * \sqrt\pi / 2 => \partialBx/\partialx = \epsilon * exp[-((x-0.5)/\sigma)**2] + ! \psi is initialized to zero everywhere. eps_mhd = patch_icpp(patch_id)%a(2) sigma = patch_icpp(patch_id)%a(3) @@ -252,8 +241,7 @@ ! B-field q_prim_vf(B_idx%beg)%sf(i, j, 0) = 1._wp + C_mhd*erf((x_cc(i) - 0.5_wp)/sigma) - - case (261) ! Blob + case (261) ! Blob r0 = 1._wp/sqrt(8._wp) r2 = x_cc(i)**2 + y_cc(j)**2 r = sqrt(r2) @@ -264,9 +252,8 @@ ! q_prim_vf(B_idx%beg)%sf(i,j,0) = 1._wp/(4._wp*pi) * (alpha**8 - 2._wp*alpha**4 + 1._wp) ! q_prim_vf(E_idx)%sf(i,j,0) = 6._wp - q_prim_vf(B_idx%beg)%sf(i,j,0)**2/2._wp end if - - case (262) ! Tilted 2D MHD shock‐tube at α = arctan2 (≈63.4°) - ! rotate by α = atan(2) + case (262) ! Tilted 2D MHD shock‐tube at α = arctan2 (≈63.4°) + ! rotate by \alpha = atan(2) alpha = atan(2._wp) cosA = cos(alpha) sinA = sin(alpha) @@ -274,69 +261,71 @@ r = x_cc(i)*cosA + y_cc(j)*sinA if (r <= 0.5_wp) then - ! LEFT state: ρ=1, v∥=+10, v⊥=0, p=20, B∥=B⊥=5/√(4π) + ! LEFT state: \rho=1, v\parallel=+10, v\perp=0, p=20, B\parallel=B\perp=5/\sqrt(4\pi) q_prim_vf(contxb)%sf(i, j, 0) = 1._wp q_prim_vf(momxb)%sf(i, j, 0) = 10._wp*cosA q_prim_vf(momxb + 1)%sf(i, j, 0) = 10._wp*sinA q_prim_vf(E_idx)%sf(i, j, 0) = 20._wp - q_prim_vf(B_idx%beg)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*cosA & - - (5._wp/sqrt(4._wp*pi))*sinA - q_prim_vf(B_idx%beg + 1)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*sinA & - + (5._wp/sqrt(4._wp*pi))*cosA + q_prim_vf(B_idx%beg)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*cosA - (5._wp/sqrt(4._wp*pi))*sinA + q_prim_vf(B_idx%beg + 1)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*sinA + (5._wp/sqrt(4._wp*pi))*cosA else - ! RIGHT state: ρ=1, v∥=−10, v⊥=0, p=1, B∥=B⊥=5/√(4π) + ! RIGHT state: \rho=1, v\parallel=-10, v\perp=0, p=1, B\parallel=B\perp=5/\sqrt(4\pi) q_prim_vf(contxb)%sf(i, j, 0) = 1._wp q_prim_vf(momxb)%sf(i, j, 0) = -10._wp*cosA q_prim_vf(momxb + 1)%sf(i, j, 0) = -10._wp*sinA q_prim_vf(E_idx)%sf(i, j, 0) = 1._wp - q_prim_vf(B_idx%beg)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*cosA & - - (5._wp/sqrt(4._wp*pi))*sinA - q_prim_vf(B_idx%beg + 1)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*sinA & - + (5._wp/sqrt(4._wp*pi))*cosA + q_prim_vf(B_idx%beg)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*cosA - (5._wp/sqrt(4._wp*pi))*sinA + q_prim_vf(B_idx%beg + 1)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*sinA + (5._wp/sqrt(4._wp*pi))*cosA end if ! v^z and B^z remain zero by default - case (270) ! This hardcoded case extrudes a 1D profile to initialize a 2D simulation domain @: HardcodedReadValues() - case (280) ! This is patch is hard-coded for test suite optimization used in the ! 2D_isentropicvortex case: ! This analytic patch uses geometry 2 if (patch_id == 1) then - q_prim_vf(E_idx)%sf(i, j, 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**(1.4 + 1.0) - q_prim_vf(contxb + 0)%sf(i, j, 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**1.4 - q_prim_vf(momxb + 0)%sf(i, j, 0) = 0.0 + (y_cc(j) - patch_icpp(1)%y_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) - q_prim_vf(momxb + 1)%sf(i, j, 0) = 0.0 - (x_cc(i) - patch_icpp(1)%x_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) + q_prim_vf(E_idx)%sf(i, j, & + & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & + & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**(1.4 + 1.0) + q_prim_vf(contxb + 0)%sf(i, j, & + & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & + & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**1.4 + q_prim_vf(momxb + 0)%sf(i, j, & + & 0) = 0.0 + (y_cc(j) - patch_icpp(1)%y_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & + & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) + q_prim_vf(momxb + 1)%sf(i, j, & + & 0) = 0.0 - (x_cc(i) - patch_icpp(1)%x_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & + & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) end if - case (281) ! This is patch is hard-coded for test suite optimization used in the ! 2D_acoustic_pulse case: ! This analytic patch uses geometry 2 if (patch_id == 2) then - q_prim_vf(E_idx)%sf(i, j, 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) - q_prim_vf(contxb + 0)%sf(i, j, 0) = 1*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) + q_prim_vf(E_idx)%sf(i, j, & + & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) + q_prim_vf(contxb + 0)%sf(i, j, & + & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) end if - case (282) ! This is patch is hard-coded for test suite optimization used in the ! 2D_zero_circ_vortex case: ! This analytic patch uses geometry 2 if (patch_id == 2) then - q_prim_vf(E_idx)%sf(i, j, 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) - q_prim_vf(contxb + 0)%sf(i, j, 0) = 1*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) - q_prim_vf(momxb + 0)%sf(i, j, 0) = 112.99092883944267*(1 - (0.1/0.3))*y_cc(j)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) + q_prim_vf(E_idx)%sf(i, j, & + & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) + q_prim_vf(contxb + 0)%sf(i, j, & + & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) + q_prim_vf(momxb + 0)%sf(i, j, & + & 0) = 112.99092883944267*(1 - (0.1/0.3))*y_cc(j)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) q_prim_vf(momxb + 1)%sf(i, j, 0) = 112.99092883944267*((0.1/0.3))*x_cc(i)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) end if - case default if (proc_rank == 0) then call s_int_to_str(patch_id, iStr) - call s_mpi_abort("Invalid hcid specified for patch "//trim(iStr)) + call s_mpi_abort("Invalid hcid specified for patch " // trim(iStr)) end if - end select - #:enddef diff --git a/src/common/include/3dHardcodedIC.fpp b/src/common/include/3dHardcodedIC.fpp index 40d5f03ad3..115123f1f6 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -7,15 +7,14 @@ ! Arrays to stor position and radii of jets from input file real(wp), dimension(:), allocatable :: y_th_arr, z_th_arr, r_th_arr ! Variables to describe initial condition of jet - real(wp) :: r, ux_th, ux_am, p_th, p_am, rho_th, rho_am, y_th, z_th, r_th, eps_smooth - real(wp) :: rcut, xcut ! Intermediate variables for creating smooth initial condition - + real(wp) :: r, ux_th, ux_am, p_th, p_am, rho_th, rho_am, y_th, z_th, r_th, eps_smooth + real(wp) :: rcut, xcut ! Intermediate variables for creating smooth initial condition real(wp), dimension(0:n, 0:p) :: rcut_arr - integer :: l, q, s ! Iterators for reading input files - integer :: start, end ! Ints to keep track of position in file - character(len=1000) :: line ! String to store line in ile - character(len=25) :: value ! String to store value in line - integer :: NJet ! Number of jets + integer :: l, q, s ! Iterators for reading input files + integer :: start, end ! Ints to keep track of position in file + character(len=1000) :: line ! String to store line in ile + character(len=25) :: value ! String to store value in line + integer :: NJet ! Number of jets eps = 1e-9_wp @@ -31,20 +30,20 @@ open (unit=10, file="jets.csv", status="old", action="read") do q = 0, NJet - 1 - read (10, '(A)') line ! Read a full line as a string + read (10, '(A)') line ! Read a full line as a string start = 1 do l = 0, 2 - end = index(line(start:), ',') ! Find the next comma + end = index(line(start:), ',') ! Find the next comma if (end == 0) then - value = trim(adjustl(line(start:))) ! Last value in the line + value = trim(adjustl(line(start:))) ! Last value in the line else - value = trim(adjustl(line(start:start + end - 2))) ! Extract substring - start = start + end ! Move to next value + value = trim(adjustl(line(start:start + end - 2))) ! Extract substring + start = start + end ! Move to next value end if if (l == 0) then - read (value, *) y_th_arr(q) ! Convert string to numeric value - elseif (l == 1) then + read (value, *) y_th_arr(q) ! Convert string to numeric value + else if (l == 1) then read (value, *) z_th_arr(q) else read (value, *) r_th_arr(q) @@ -64,11 +63,9 @@ end do end do end if - #:enddef #:def Hardcoded3D() - select case (patch_icpp(patch_id)%hcid) case (300) ! Rayleigh-Taylor instability rhoH = 3._wp @@ -101,7 +98,6 @@ pInt = pref + rhoH*9.81_wp*(1.2_wp - intH) q_prim_vf(E_idx)%sf(i, j, k) = pInt + rhoL*9.81_wp*(intH - y_cc(j)) end if - case (301) ! (3D lung geometry in X direction, |sin(*)+sin(*)|) h = 0.0_wp lam = 1.0_wp @@ -114,7 +110,6 @@ q_prim_vf(advxb)%sf(i, j, k) = patch_icpp(1)%alpha(1) q_prim_vf(advxe)%sf(i, j, k) = patch_icpp(1)%alpha(2) end if - case (302) ! 3D Jet with IGR ux_th = 10*sqrt(1.4*0.4) ux_am = 0.0*sqrt(1.4) @@ -145,7 +140,6 @@ end if q_prim_vf(E_idx)%sf(i, j, k) = p_th*rcut*xcut + p_am - case (303) ! 3D Multijet eps_smooth = 3.0_wp @@ -173,25 +167,22 @@ end if q_prim_vf(E_idx)%sf(i, j, k) = p_th*rcut*xcut + p_am - case (370) ! This hardcoded case extrudes a 2D profile to initialize a 3D simulation domain @: HardcodedReadValues() - case (380) ! This is patch is hard-coded for test suite optimization used in the ! 3D_TaylorGreenVortex case: ! This analytic patch used geometry 9 Mach = 0.1 if (patch_id == 1) then - q_prim_vf(E_idx)%sf(i, j, k) = 101325 + (Mach**2*376.636429464809**2/16)*(cos(2*x_cc(i)/1) + cos(2*y_cc(j)/1))*(cos(2*z_cc(k)/1) + 2) + q_prim_vf(E_idx)%sf(i, j, & + & k) = 101325 + (Mach**2*376.636429464809**2/16)*(cos(2*x_cc(i)/1) + cos(2*y_cc(j)/1))*(cos(2*z_cc(k)/1) + 2) q_prim_vf(momxb + 0)%sf(i, j, k) = Mach*376.636429464809*sin(x_cc(i)/1)*cos(y_cc(j)/1)*sin(z_cc(k)/1) q_prim_vf(momxb + 1)%sf(i, j, k) = -Mach*376.636429464809*cos(x_cc(i)/1)*sin(y_cc(j)/1)*sin(z_cc(k)/1) end if - case default call s_int_to_str(patch_id, iStr) - call s_mpi_abort("Invalid hcid specified for patch "//trim(iStr)) + call s_mpi_abort("Invalid hcid specified for patch " // trim(iStr)) end select - #:enddef diff --git a/src/common/include/ExtrusionHardcodedIC.fpp b/src/common/include/ExtrusionHardcodedIC.fpp index 264b227f21..7a6fbeb0e8 100644 --- a/src/common/include/ExtrusionHardcodedIC.fpp +++ b/src/common/include/ExtrusionHardcodedIC.fpp @@ -1,74 +1,73 @@ !> @brief Allocate memory and read initial condition data for IC extrusion. !> !> @details -!> This macro handles the complete initialization process for IC extrusion by: +!> This macro handles the complete initialization process for IC extrusion by: !> -!> **Memory Allocation:** -!> - stored_values(xRows, yRows, sys_size) - stores primitive variable data from files -!> - x_coords(nrows) - stores x-coordinates from input files -!> - y_coords(nrows) - stores y-coordinates from input files (3D case only) +!> **Memory Allocation:** +!> - stored_values(xRows, yRows, sys_size) - stores primitive variable data from files +!> - x_coords(nrows) - stores x-coordinates from input files +!> - y_coords(nrows) - stores y-coordinates from input files (3D case only) !> -!> **File Reading Operations:** -!> - Reads primitive variable data from multiple files with pattern: -!> `prim..00..dat` where timestep uses `zeros_default` padding -!> - Files are read from directory specified by `init_dir` parameter -!> - Supports 1D, 2D, and 3D computational domains +!> **File Reading Operations:** +!> - Reads primitive variable data from multiple files with pattern: +!> `prim..00..dat` where timestep uses `zeros_default` padding +!> - Files are read from directory specified by `init_dir` parameter +!> - Supports 1D, 2D, and 3D computational domains !> -!> **Grid Structure Detection:** -!> - 1D/2D: Counts lines in first file to determine xRows -!> - 3D: Analyzes coordinate patterns to determine xRows and yRows structure +!> **Grid Structure Detection:** +!> - 1D/2D: Counts lines in first file to determine xRows +!> - 3D: Analyzes coordinate patterns to determine xRows and yRows structure !> -!> **MPI Domain Mapping:** -!> - Calculates global_offset_x and global_offset_y for MPI subdomain positioning -!> - Maps file coordinates to local computational grid coordinates +!> **MPI Domain Mapping:** +!> - Calculates global_offset_x and global_offset_y for MPI subdomain positioning +!> - Maps file coordinates to local computational grid coordinates !> -!> **Data Assignment:** -!> - Populates q_prim_vf primitive variable arrays with file data -!> - Handles momentum component indexing with special treatment for momxe -!> - Sets momxe component to zero for 2D/3D cases +!> **Data Assignment:** +!> - Populates q_prim_vf primitive variable arrays with file data +!> - Handles momentum component indexing with special treatment for momxe +!> - Sets momxe component to zero for 2D/3D cases !> -!> **State Management:** -!> - Uses files_loaded flag to prevent redundant file operations -!> - Preserves data across multiple macro calls within same simulation +!> **State Management:** +!> - Uses files_loaded flag to prevent redundant file operations +!> - Preserves data across multiple macro calls within same simulation !> -!> @note File pattern uses `zeros_default` parameter (default: "000000") for timestep padding -!> @note Directory path is hardcoded in `init_dir` parameter - modify as needed -!> @warning Aborts execution if file reading errors occur. +!> @note File pattern uses `zeros_default` parameter (default: "000000") for timestep padding +!> @note Directory path is hardcoded in `init_dir` parameter - modify as needed +!> @warning Aborts execution if file reading errors occur. #:def HardcodedDimensionsExtrusion() - integer :: xRows, yRows, nRows, iix, iiy, max_files - integer :: f, iter, ios, ios2, unit, unit2, idx, idy, index_x, index_y, jump, line_count, ycount - real(wp) :: x_len, x_step, y_len, y_step - real(wp) :: dummy_x, dummy_y, dummy_z, x0, y0 - integer :: global_offset_x, global_offset_y ! MPI subdomain offset - real(wp) :: delta_x, delta_y + integer :: xRows, yRows, nRows, iix, iiy, max_files + integer :: f, iter, ios, ios2, unit, unit2, idx, idy, index_x, index_y, jump, line_count, ycount + real(wp) :: x_len, x_step, y_len, y_step + real(wp) :: dummy_x, dummy_y, dummy_z, x0, y0 + integer :: global_offset_x, global_offset_y ! MPI subdomain offset + real(wp) :: delta_x, delta_y character(len=100), dimension(sys_size) :: fileNames ! Arrays to store all data from files - character(len=200) :: errmsg - real(wp), allocatable :: stored_values(:, :, :) - real(wp), allocatable :: x_coords(:), y_coords(:) - logical :: files_loaded = .false. - real(wp) :: domain_xstart, domain_xend, domain_ystart, domain_yend - character(len=*), parameter :: init_dir = "/home/MFC/FilesDirectory" ! For example /home/MFC/examples/1D_Shock/D/ - character(len=20) :: file_num_str ! For storing the file number as a string - character(len=20) :: zeros_part ! For the trailing zeros part - character(len=6), parameter :: zeros_default = "000000" ! Default zeros (can be changed) + character(len=200) :: errmsg + real(wp), allocatable :: stored_values(:,:,:) + real(wp), allocatable :: x_coords(:), y_coords(:) + logical :: files_loaded = .false. + real(wp) :: domain_xstart, domain_xend, domain_ystart, domain_yend + character(len=*), parameter :: init_dir = "/home/MFC/FilesDirectory" ! For example /home/MFC/examples/1D_Shock/D/ + character(len=20) :: file_num_str ! For storing the file number as a string + character(len=20) :: zeros_part ! For the trailing zeros part + character(len=6), parameter :: zeros_default = "000000" ! Default zeros (can be changed) #:enddef #:def HardcodedReadValues() - if (.not. files_loaded) then max_files = merge(sys_size, sys_size - 1, num_dims == 1) do f = 1, max_files write (file_num_str, '(I0)') f - fileNames(f) = trim(init_dir)//"prim."//trim(file_num_str)//".00."//zeros_default//".dat" + fileNames(f) = trim(init_dir) // "prim." // trim(file_num_str) // ".00." // zeros_default // ".dat" end do ! Common file reading setup open (newunit=unit2, file=trim(fileNames(1)), status='old', action='read', iostat=ios2) - if (ios2 /= 0) call s_mpi_abort("Error opening file: "//trim(fileNames(1))) + if (ios2 /= 0) call s_mpi_abort("Error opening file: " // trim(fileNames(1))) select case (num_dims) - case (1, 2) ! 1D and 2D cases are similar + case (1, 2) ! 1D and 2D cases are similar ! Count lines line_count = 0 do @@ -82,16 +81,16 @@ yRows = 1 index_x = 0 if (num_dims == 2) index_x = i - @:ALLOCATE (x_coords(xRows), stored_values(xRows, 1, sys_size)) + @:ALLOCATE(x_coords(xRows), stored_values(xRows, 1, sys_size)) ! Read data from all files do f = 1, max_files open (newunit=unit, file=trim(fileNames(f)), status='old', action='read', iostat=ios) - if (ios /= 0) call s_mpi_abort("Error opening file: "//trim(fileNames(f))) + if (ios /= 0) call s_mpi_abort("Error opening file: " // trim(fileNames(f))) do iter = 1, xRows read (unit, *, iostat=ios) x_coords(iter), stored_values(iter, 1, f) - if (ios /= 0) call s_mpi_abort("Error reading file: "//trim(fileNames(f))) + if (ios /= 0) call s_mpi_abort("Error reading file: " // trim(fileNames(f))) end do close (unit) end do @@ -99,11 +98,9 @@ ! Calculate offsets domain_xstart = x_coords(1) x_step = x_cc(1) - x_cc(0) - delta_x = merge(x_cc(0) - domain_xstart + x_step/2.0, & - x_cc(index_x) - domain_xstart + x_step/2.0, num_dims == 1) + delta_x = merge(x_cc(0) - domain_xstart + x_step/2.0, x_cc(index_x) - domain_xstart + x_step/2.0, num_dims == 1) global_offset_x = nint(abs(delta_x)/x_step) - - case (3) ! 3D case - determine grid structure + case (3) ! 3D case - determine grid structure ! Find yRows by counting rows with same x read (unit2, *, iostat=ios2) x0, y0, dummy_z if (ios2 /= 0) call s_mpi_abort("Error reading first line") @@ -131,7 +128,7 @@ close (unit2) xRows = nrows/yRows - @:ALLOCATE (x_coords(nrows), y_coords(nrows), stored_values(xRows, yRows, sys_size)) + @:ALLOCATE(x_coords(nrows), y_coords(nrows), stored_values(xRows, yRows, sys_size)) index_x = i index_y = j @@ -139,7 +136,7 @@ do f = 1, max_files open (newunit=unit, file=trim(fileNames(f)), status='old', action='read', iostat=ios) if (ios /= 0) then - if (f == 1) call s_mpi_abort("Error opening file: "//trim(fileNames(f))) + if (f == 1) call s_mpi_abort("Error opening file: " // trim(fileNames(f))) cycle end if @@ -177,7 +174,6 @@ do f = 1, sys_size q_prim_vf(f)%sf(i, 0, 0) = stored_values(idx, 1, f) end do - case (2) idx = i + 1 + global_offset_x - index_x do f = 1, sys_size - 1 @@ -185,7 +181,6 @@ q_prim_vf(f + jump)%sf(i, j, 0) = stored_values(idx, 1, f) end do q_prim_vf(momxe)%sf(i, j, 0) = 0.0_wp - case (3) idx = i + 1 + global_offset_x - index_x idy = j + 1 + global_offset_y - index_y @@ -199,11 +194,11 @@ #:def HardcodedDellacation() if (allocated(stored_values)) then - @:DEALLOCATE (stored_values) - @:DEALLOCATE (x_coords) + @:DEALLOCATE(stored_values) + @:DEALLOCATE(x_coords) end if if (allocated(y_coords)) then - @:DEALLOCATE (y_coords) + @:DEALLOCATE(y_coords) end if #:enddef diff --git a/src/common/include/acc_macros.fpp b/src/common/include/acc_macros.fpp index 771ee976db..f6848a103e 100644 --- a/src/common/include/acc_macros.fpp +++ b/src/common/include/acc_macros.fpp @@ -196,7 +196,7 @@ #:if data_dependency is not None #:assert isinstance(data_dependency, str) #:assert (data_dependency == 'auto' or data_dependency == 'independent') - #:set data_dependency_val = data_dependency + #:set data_dependency_val = data_dependency #:else #:set data_dependency_val = '' #:endif @@ -229,7 +229,7 @@ #:set extraAccArgs_val = GEN_EXTRA_ARGS_STR(extraAccArgs) #:set clause_val = copy_val.strip('\n') + copyin_val.strip('\n') + & & copyout_val.strip('\n') + create_val.strip('\n') + & - & no_create_val.strip('\n') + present_val.strip('\n') + & + & no_create_val.strip('\n') + present_val.strip('\n') + & & deviceptr_val.strip('\n') + attach_val.strip('\n') + & & default_val.strip('\n') #:set acc_directive = '!$acc data ' + clause_val + extraAccArgs_val.strip('\n') diff --git a/src/common/include/macros.fpp b/src/common/include/macros.fpp index 03d812f53d..c2bc2111c1 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -20,12 +20,12 @@ #ifdef MFC_SIMULATION #ifdef __NVCOMPILER_GPU_UNIFIED_MEM block -! Beginning in the 25.3 release, the structure of the cudafor module has been changed slightly. -! The module now includes, or “uses” 3 submodules: cuda_runtime_api, gpu_reductions, and sort. -! The cudafor functionality has not changed. But for new users, or users who have needed to -! work-around name conflicts in the module, it may be better to use cuda_runtime_api to expose -! interfaces to the CUDA runtime calls described in Chapter 4 of this guide. -! https://docs.nvidia.com/hpc-sdk/compilers/cuda-fortran-prog-guide/index.html#fortran-host-modules + ! Beginning in the 25.3 release, the structure of the cudafor module has been changed slightly. + ! The module now includes, or "uses" 3 submodules: cuda_runtime_api, gpu_reductions, and sort. + ! The cudafor functionality has not changed. But for new users, or users who have needed to + ! work-around name conflicts in the module, it may be better to use cuda_runtime_api to expose + ! interfaces to the CUDA runtime calls described in Chapter 4 of this guide. + ! https://docs.nvidia.com/hpc-sdk/compilers/cuda-fortran-prog-guide/index.html#fortran-host-modules #if __NVCOMPILER_MAJOR__ < 25 || (__NVCOMPILER_MAJOR__ == 25 && __NVCOMPILER_MINOR__ < 3) use cudafor, gpu_sum => sum, gpu_maxval => maxval, gpu_minval => minval #else @@ -35,24 +35,24 @@ if (nv_uvm_pref_gpu) then #:for arg in args - !print*, "Moving ${arg}$ to GPU => ", SHAPE(${arg}$) + ! print*, "Moving ${arg}$ to GPU => ", SHAPE(${arg}$) ! set preferred location GPU istat = cudaMemAdvise(c_devloc(${arg}$), SIZEOF(${arg}$), cudaMemAdviseSetPreferredLocation, 0) if (istat /= cudaSuccess) then write (*, "('Error code: ',I0, ': ')") istat - !write(*,*) cudaGetErrorString(istat) + ! write(*,*) cudaGetErrorString(istat) end if ! set accessed by CPU istat = cudaMemAdvise(c_devloc(${arg}$), SIZEOF(${arg}$), cudaMemAdviseSetAccessedBy, cudaCpuDeviceId) if (istat /= cudaSuccess) then write (*, "('Error code: ',I0, ': ')") istat - !write(*,*) cudaGetErrorString(istat) + ! write(*,*) cudaGetErrorString(istat) end if ! prefetch to GPU - physically populate memory pages istat = cudaMemPrefetchAsync(c_devloc(${arg}$), SIZEOF(${arg}$), 0, 0) if (istat /= cudaSuccess) then write (*, "('Error code: ',I0, ': ')") istat - !write(*,*) cudaGetErrorString(istat) + ! write(*,*) cudaGetErrorString(istat) end if #:endfor end if @@ -112,7 +112,6 @@ #:def ACC_SETUP_SFs(*args) #ifdef _CRAYFTN block - @:LOG({'@:ACC_SETUP_SFs(${', '.join(args)}$)'}) #:for arg in args @@ -128,7 +127,6 @@ #:def ACC_SETUP_source_spatials(*args) #ifdef _CRAYFTN block - @:LOG({'@:ACC_SETUP_source_spatials(${', '.join(args)}$)'}) #:for arg in args @@ -146,7 +144,6 @@ $:GPU_ENTER_DATA(copyin=('[' + arg + '%xyz_to_r_ratios]')) end if #:endfor - end block #endif #:enddef @@ -159,9 +156,8 @@ #:def ASSERT(predicate, message = None) if (.not. (${predicate}$)) then - call s_mpi_abort("${_FILE_.split('/')[-1]}$:${_LINE_}$: "// & - "Assertion failed: ${predicate}$. " & - //${message or '"No error description."'}$) + call s_mpi_abort("${_FILE_.split('/')[-1]}$:${_LINE_}$: " // "Assertion failed: ${predicate}$. " & + & // ${message or '"No error description."'}$) end if #:enddef ! New line at end of file is required for FYPP diff --git a/src/common/include/omp_macros.fpp b/src/common/include/omp_macros.fpp index 2e1df1dd8a..db25f1a81c 100644 --- a/src/common/include/omp_macros.fpp +++ b/src/common/include/omp_macros.fpp @@ -8,7 +8,7 @@ #:def OMP_MAP_STR(map_type, var_list) #:assert map_type is not None - #:assert isinstance(map_type, str) + #:assert isinstance(map_type, str) #:if var_list is not None #:set map_clause = 'map(' + map_type + ':' #:set map_val = GEN_CLAUSE(map_clause, var_list) @@ -85,13 +85,13 @@ #:enddef #! #:def OMP_ATTACH_STR(attach) - #! #:set attach_val = OMP_MAP_STR('always,to', attach) - #! $:attach_val +#! #:set attach_val = OMP_MAP_STR('always,to', attach) +#! $:attach_val #! #:enddef #! #:def OMP_DETACH_STR(detach) - #! #:set detach_val = OMP_MAP_STR('always,from', detach) - #! $:detach_val +#! #:set detach_val = OMP_MAP_STR('always,from', detach) +#! $:detach_val #! #:enddef #:def OMP_TO_STR(to) @@ -110,13 +110,13 @@ #:enddef #:def OMP_USE_DEVICE_ADDR_STR(use_device_addr) - #:set use_device_addr_val = GEN_PARENTHESES_CLAUSE('use_device_addr', use_device_addr) - $:use_device_addr_val + #:set use_device_addr_val = GEN_PARENTHESES_CLAUSE('use_device_addr', use_device_addr) + $:use_device_addr_val #:enddef #:def OMP_USE_DEVICE_PTR_STR(use_device_ptr) - #:set use_device_ptr_val = GEN_PARENTHESES_CLAUSE('use_device_ptr', use_device_ptr) - $:use_device_ptr_val + #:set use_device_ptr_val = GEN_PARENTHESES_CLAUSE('use_device_ptr', use_device_ptr) + $:use_device_ptr_val #:enddef #:def OMP_PARALLEL(code, private=None, default='present', firstprivate=None, reduction=None, reductionOp=None, & @@ -139,7 +139,7 @@ & copyout_val.strip('\n') + create_val.strip('\n') + & & no_create_val.strip('\n') + present_val.strip('\n') + & & deviceptr_val.strip('\n') + attach_val.strip('\n') - + #:set omp_clause_val = omp_clause_val.strip('\n') #:set omp_directive = '!$omp target teams ' + omp_clause_val + extraOmpArgs_val.strip('\n') @@ -153,7 +153,7 @@ & default='present', firstprivate=None, reduction=None, reductionOp=None, & & copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, & & no_create=None, present=None, deviceptr=None, attach=None, extraOmpArgs=None) - + #:set collapse_val = GEN_COLLAPSE_STR(collapse) #:set parallelism_val = OMP_PARALLELISM_STR(parallelism) #:set default_val = OMP_DEFAULT_STR(default) @@ -191,7 +191,6 @@ #:enddef #:def END_OMP_PARALLEL_LOOP() - #:if MFC_COMPILER == NVIDIA_COMPILER_ID or MFC_COMPILER == PGI_COMPILER_ID #:set omp_end_directive = '!$omp end target teams loop' #:elif MFC_COMPILER == CCE_COMPILER_ID @@ -218,7 +217,7 @@ #:else #:set function_name_val = '' #:endif - + #:if MFC_COMPILER == AMD_COMPILER_ID #:set clause_val = '' #:else @@ -271,7 +270,7 @@ #:set extraOmpArgs_val = GEN_EXTRA_ARGS_STR(extraOmpArgs) #:set clause_val = copy_val.strip('\n') + copyin_val.strip('\n') + & & copyout_val.strip('\n') + create_val.strip('\n') + & - & no_create_val.strip('\n') + present_val.strip('\n') + & + & no_create_val.strip('\n') + present_val.strip('\n') + & & deviceptr_val.strip('\n') + attach_val.strip('\n') + & & default_val.strip('\n') #:set omp_directive = '!$omp target data ' + clause_val + extraOmpArgs_val.strip('\n') diff --git a/src/common/include/parallel_macros.fpp b/src/common/include/parallel_macros.fpp index a13bcbdfcb..569af3df3a 100644 --- a/src/common/include/parallel_macros.fpp +++ b/src/common/include/parallel_macros.fpp @@ -16,7 +16,6 @@ #else $:code #endif - #:enddef #:def GPU_PARALLEL_LOOP(collapse=None, private=None, parallelism='[gang, vector]', & @@ -32,11 +31,9 @@ #elif defined(MFC_OpenMP) $:omp_directive #endif - #:enddef #:def END_GPU_PARALLEL_LOOP() - #:set acc_end_directive = '!$acc end parallel loop' #:set omp_end_directive = END_OMP_PARALLEL_LOOP() @@ -45,7 +42,6 @@ #elif defined(MFC_OpenMP) $:omp_end_directive #endif - #:enddef #:def GPU_ROUTINE(function_name=None, parallelism=None, nohost=False, cray_inline=False, cray_noinline=False, extraAccArgs=None, extraOmpArgs=None) @@ -142,7 +138,6 @@ #:enddef #:def GPU_HOST_DATA(code, use_device_addr=None, use_device_ptr=None, extraAccArgs=None, extraOmpArgs=None) - #:if use_device_addr is not None and use_device_ptr is not None #:set use_device_addr_end_index = len(use_device_addr) - 1 #:set use_device = use_device_addr + use_device_ptr @@ -235,13 +230,11 @@ #:enddef #:def USE_GPU_MODULE() - #if defined(MFC_OpenACC) use openacc #elif defined(MFC_OpenMP) use omp_lib #endif - #:enddef #:def DEF_AMD(code) diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 2a33ecfc60..b9221643fd 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -7,7 +7,6 @@ #:include 'macros.fpp' module m_boundary_common - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -22,7 +21,7 @@ module m_boundary_common implicit none - type(scalar_field), dimension(:, :), allocatable :: bc_buffers + type(scalar_field), dimension(:,:), allocatable :: bc_buffers $:GPU_DECLARE(create='[bc_buffers]') #ifdef MFC_MPI @@ -30,30 +29,21 @@ module m_boundary_common integer, dimension(1:3, 1:2) :: MPI_BC_BUFFER_TYPE #endif - private; public :: s_initialize_boundary_common_module, & - s_populate_variables_buffers, & - s_create_mpi_types, & - s_populate_capillary_buffers, & - s_populate_F_igr_buffers, & - s_write_serial_boundary_condition_files, & - s_write_parallel_boundary_condition_files, & - s_read_serial_boundary_condition_files, & - s_read_parallel_boundary_condition_files, & - s_assign_default_bc_type, & - s_populate_grid_variables_buffers, & - s_finalize_boundary_common_module + private; public :: s_initialize_boundary_common_module, s_populate_variables_buffers, s_create_mpi_types, & + & s_populate_capillary_buffers, s_populate_F_igr_buffers, s_write_serial_boundary_condition_files, & + & s_write_parallel_boundary_condition_files, s_read_serial_boundary_condition_files, & + & s_read_parallel_boundary_condition_files, s_assign_default_bc_type, s_populate_grid_variables_buffers, & + & s_finalize_boundary_common_module public :: bc_buffers #ifdef MFC_MPI public :: MPI_BC_TYPE_TYPE, MPI_BC_BUFFER_TYPE #endif - contains !> @brief Allocates and sets up boundary condition buffer arrays for all coordinate directions. impure subroutine s_initialize_boundary_common_module() - integer :: i, j @:ALLOCATE(bc_buffers(1:3, 1:2)) @@ -78,27 +68,21 @@ contains @:ACC_SETUP_SFs(bc_buffers(i,j)) end do end do - end if - end subroutine s_initialize_boundary_common_module - - !> The purpose of this procedure is to populate the buffers - !! of the primitive variables, depending on the selected - !! boundary conditions. + !> The purpose of this procedure is to populate the buffers of the primitive variables, depending on the selected boundary + !! conditions. impure subroutine s_populate_variables_buffers(bc_type, q_prim_vf, pb_in, mv_in) - - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - - integer :: k, l + type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type + integer :: k, l ! Population of Buffers in x-direction if (bc_x%beg >= 0) then call s_mpi_sendrecv_variables_buffers(q_prim_vf, 1, -1, sys_size, pb_in, mv_in) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = 0, n select case (int(bc_type(1, 1)%sf(0, k, l))) @@ -116,8 +100,7 @@ contains call s_dirichlet(q_prim_vf, 1, -1, k, l) end select - if (qbmm .and. (.not. polytropic) .and. & - (bc_type(1, 1)%sf(0, k, l) <= BC_GHOST_EXTRAP)) then + if (qbmm .and. (.not. polytropic) .and. (bc_type(1, 1)%sf(0, k, l) <= BC_GHOST_EXTRAP)) then call s_qbmm_extrapolation(1, -1, k, l, pb_in, mv_in) end if end do @@ -128,7 +111,7 @@ contains if (bc_x%end >= 0) then call s_mpi_sendrecv_variables_buffers(q_prim_vf, 1, 1, sys_size, pb_in, mv_in) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = 0, n select case (int(bc_type(1, 2)%sf(0, k, l))) @@ -146,8 +129,7 @@ contains call s_dirichlet(q_prim_vf, 1, 1, k, l) end select - if (qbmm .and. (.not. polytropic) .and. & - (bc_type(1, 2)%sf(0, k, l) <= BC_GHOST_EXTRAP)) then + if (qbmm .and. (.not. polytropic) .and. (bc_type(1, 2)%sf(0, k, l) <= BC_GHOST_EXTRAP)) then call s_qbmm_extrapolation(1, 1, k, l, pb_in, mv_in) end if end do @@ -160,11 +142,10 @@ contains if (n == 0) return #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (bc_y%beg >= 0) then call s_mpi_sendrecv_variables_buffers(q_prim_vf, 2, -1, sys_size, pb_in, mv_in) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = -buff_size, m + buff_size select case (int(bc_type(2, 1)%sf(k, 0, l))) @@ -184,9 +165,8 @@ contains call s_dirichlet(q_prim_vf, 2, -1, k, l) end select - if (qbmm .and. (.not. polytropic) .and. & - (bc_type(2, 1)%sf(k, 0, l) <= BC_GHOST_EXTRAP) .and. & - (bc_type(2, 1)%sf(k, 0, l) /= BC_AXIS)) then + if (qbmm .and. (.not. polytropic) .and. (bc_type(2, 1)%sf(k, 0, l) <= BC_GHOST_EXTRAP) .and. (bc_type(2, & + & 1)%sf(k, 0, l) /= BC_AXIS)) then call s_qbmm_extrapolation(2, -1, k, l, pb_in, mv_in) end if end do @@ -197,7 +177,7 @@ contains if (bc_y%end >= 0) then call s_mpi_sendrecv_variables_buffers(q_prim_vf, 2, 1, sys_size, pb_in, mv_in) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = -buff_size, m + buff_size select case (int(bc_type(2, 2)%sf(k, 0, l))) @@ -215,15 +195,13 @@ contains call s_dirichlet(q_prim_vf, 2, 1, k, l) end select - if (qbmm .and. (.not. polytropic) .and. & - (bc_type(2, 2)%sf(k, 0, l) <= BC_GHOST_EXTRAP)) then + if (qbmm .and. (.not. polytropic) .and. (bc_type(2, 2)%sf(k, 0, l) <= BC_GHOST_EXTRAP)) then call s_qbmm_extrapolation(2, 1, k, l, pb_in, mv_in) end if end do end do $:END_GPU_PARALLEL_LOOP() end if - #:endif ! Population of Buffers in z-direction @@ -231,11 +209,10 @@ contains if (p == 0) return #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (bc_z%beg >= 0) then call s_mpi_sendrecv_variables_buffers(q_prim_vf, 3, -1, sys_size, pb_in, mv_in) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size select case (int(bc_type(3, 1)%sf(k, l, 0))) @@ -253,8 +230,7 @@ contains call s_dirichlet(q_prim_vf, 3, -1, k, l) end select - if (qbmm .and. (.not. polytropic) .and. & - (bc_type(3, 1)%sf(k, l, 0) <= BC_GHOST_EXTRAP)) then + if (qbmm .and. (.not. polytropic) .and. (bc_type(3, 1)%sf(k, l, 0) <= BC_GHOST_EXTRAP)) then call s_qbmm_extrapolation(3, -1, k, l, pb_in, mv_in) end if end do @@ -265,7 +241,7 @@ contains if (bc_z%end >= 0) then call s_mpi_sendrecv_variables_buffers(q_prim_vf, 3, 1, sys_size, pb_in, mv_in) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size select case (int(bc_type(3, 2)%sf(k, l, 0))) @@ -283,8 +259,7 @@ contains call s_dirichlet(q_prim_vf, 3, 1, k, l) end select - if (qbmm .and. (.not. polytropic) .and. & - (bc_type(3, 2)%sf(k, l, 0) <= BC_GHOST_EXTRAP)) then + if (qbmm .and. (.not. polytropic) .and. (bc_type(3, 2)%sf(k, l, 0) <= BC_GHOST_EXTRAP)) then call s_qbmm_extrapolation(3, 1, k, l, pb_in, mv_in) end if end do @@ -293,119 +268,100 @@ contains end if #:endif ! END: Population of Buffers in z-direction - end subroutine s_populate_variables_buffers - !> @brief Fills ghost cells by copying the nearest boundary cell value along the specified direction. subroutine s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l) - $:GPU_ROUTINE(function_name='s_ghost_cell_extrapolation', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_ghost_cell_extrapolation', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, i if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !bc_x%beg + if (bc_loc == -1) then ! bc_x%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(-j, k, l) = & - q_prim_vf(i)%sf(0, k, l) + q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l) end do end do else !< bc_x%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(m + j, k, l) = & - q_prim_vf(i)%sf(m, k, l) + q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l) end do end do end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, 0, l) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l) end do end do else !< bc_y%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, n + j, l) = & - q_prim_vf(i)%sf(k, n, l) + q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l) end do end do end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, l, -j) = & - q_prim_vf(i)%sf(k, l, 0) + q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0) end do end do else !< bc_z%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, l, p + j) = & - q_prim_vf(i)%sf(k, l, p) + q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p) end do end do end if end if - end subroutine s_ghost_cell_extrapolation - - !> @brief Applies reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the normal velocity component. + !> @brief Applies reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the normal velocity + !! component. subroutine s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, q, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, q, i if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then !< bc_x%beg do j = 1, buff_size do i = 1, contxe - q_prim_vf(i)%sf(-j, k, l) = & - q_prim_vf(i)%sf(j - 1, k, l) + q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(j - 1, k, l) end do - q_prim_vf(momxb)%sf(-j, k, l) = & - -q_prim_vf(momxb)%sf(j - 1, k, l) + q_prim_vf(momxb)%sf(-j, k, l) = -q_prim_vf(momxb)%sf(j - 1, k, l) do i = momxb + 1, sys_size - q_prim_vf(i)%sf(-j, k, l) = & - q_prim_vf(i)%sf(j - 1, k, l) + q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(j - 1, k, l) end do if (elasticity) then do i = 1, shear_BC_flip_num - q_prim_vf(shear_BC_flip_indices(1, i))%sf(-j, k, l) = & - -q_prim_vf(shear_BC_flip_indices(1, i))%sf(j - 1, k, l) + q_prim_vf(shear_BC_flip_indices(1, i))%sf(-j, k, l) = -q_prim_vf(shear_BC_flip_indices(1, & + & i))%sf(j - 1, k, l) end do end if if (hyperelasticity) then - q_prim_vf(xibeg)%sf(-j, k, l) = & - -q_prim_vf(xibeg)%sf(j - 1, k, l) + q_prim_vf(xibeg)%sf(-j, k, l) = -q_prim_vf(xibeg)%sf(j - 1, k, l) end if - end do if (qbmm .and. .not. polytropic) then do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(-j, k, l, q, i) = & - pb_in(j - 1, k, l, q, i) - mv_in(-j, k, l, q, i) = & - mv_in(j - 1, k, l, q, i) + pb_in(-j, k, l, q, i) = pb_in(j - 1, k, l, q, i) + mv_in(-j, k, l, q, i) = mv_in(j - 1, k, l, q, i) end do end do end do @@ -413,70 +369,59 @@ contains else !< bc_x%end do j = 1, buff_size do i = 1, contxe - q_prim_vf(i)%sf(m + j, k, l) = & - q_prim_vf(i)%sf(m - (j - 1), k, l) + q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l) end do - q_prim_vf(momxb)%sf(m + j, k, l) = & - -q_prim_vf(momxb)%sf(m - (j - 1), k, l) + q_prim_vf(momxb)%sf(m + j, k, l) = -q_prim_vf(momxb)%sf(m - (j - 1), k, l) do i = momxb + 1, sys_size - q_prim_vf(i)%sf(m + j, k, l) = & - q_prim_vf(i)%sf(m - (j - 1), k, l) + q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l) end do if (elasticity) then do i = 1, shear_BC_flip_num - q_prim_vf(shear_BC_flip_indices(1, i))%sf(m + j, k, l) = & - -q_prim_vf(shear_BC_flip_indices(1, i))%sf(m - (j - 1), k, l) + q_prim_vf(shear_BC_flip_indices(1, i))%sf(m + j, k, l) = -q_prim_vf(shear_BC_flip_indices(1, & + & i))%sf(m - (j - 1), k, l) end do end if if (hyperelasticity) then - q_prim_vf(xibeg)%sf(m + j, k, l) = & - -q_prim_vf(xibeg)%sf(m - (j - 1), k, l) + q_prim_vf(xibeg)%sf(m + j, k, l) = -q_prim_vf(xibeg)%sf(m - (j - 1), k, l) end if end do if (qbmm .and. .not. polytropic) then - do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(m + j, k, l, q, i) = & - pb_in(m - (j - 1), k, l, q, i) - mv_in(m + j, k, l, q, i) = & - mv_in(m - (j - 1), k, l, q, i) + pb_in(m + j, k, l, q, i) = pb_in(m - (j - 1), k, l, q, i) + mv_in(m + j, k, l, q, i) = mv_in(m - (j - 1), k, l, q, i) end do end do end do end if end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do j = 1, buff_size do i = 1, momxb - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, j - 1, l) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l) end do - q_prim_vf(momxb + 1)%sf(k, -j, l) = & - -q_prim_vf(momxb + 1)%sf(k, j - 1, l) + q_prim_vf(momxb + 1)%sf(k, -j, l) = -q_prim_vf(momxb + 1)%sf(k, j - 1, l) do i = momxb + 2, sys_size - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, j - 1, l) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l) end do if (elasticity) then do i = 1, shear_BC_flip_num - q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, -j, l) = & - -q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, j - 1, l) + q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, -j, l) = -q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, & + & j - 1, l) end do end if if (hyperelasticity) then - q_prim_vf(xibeg + 1)%sf(k, -j, l) = & - -q_prim_vf(xibeg + 1)%sf(k, j - 1, l) + q_prim_vf(xibeg + 1)%sf(k, -j, l) = -q_prim_vf(xibeg + 1)%sf(k, j - 1, l) end if end do @@ -484,10 +429,8 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, -j, l, q, i) = & - pb_in(k, j - 1, l, q, i) - mv_in(k, -j, l, q, i) = & - mv_in(k, j - 1, l, q, i) + pb_in(k, -j, l, q, i) = pb_in(k, j - 1, l, q, i) + mv_in(k, -j, l, q, i) = mv_in(k, j - 1, l, q, i) end do end do end do @@ -495,28 +438,24 @@ contains else !< bc_y%end do j = 1, buff_size do i = 1, momxb - q_prim_vf(i)%sf(k, n + j, l) = & - q_prim_vf(i)%sf(k, n - (j - 1), l) + q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l) end do - q_prim_vf(momxb + 1)%sf(k, n + j, l) = & - -q_prim_vf(momxb + 1)%sf(k, n - (j - 1), l) + q_prim_vf(momxb + 1)%sf(k, n + j, l) = -q_prim_vf(momxb + 1)%sf(k, n - (j - 1), l) do i = momxb + 2, sys_size - q_prim_vf(i)%sf(k, n + j, l) = & - q_prim_vf(i)%sf(k, n - (j - 1), l) + q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l) end do if (elasticity) then do i = 1, shear_BC_flip_num - q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, n + j, l) = & - -q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, n - (j - 1), l) + q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, n + j, l) = -q_prim_vf(shear_BC_flip_indices(2, & + & i))%sf(k, n - (j - 1), l) end do end if if (hyperelasticity) then - q_prim_vf(xibeg + 1)%sf(k, n + j, l) = & - -q_prim_vf(xibeg + 1)%sf(k, n - (j - 1), l) + q_prim_vf(xibeg + 1)%sf(k, n + j, l) = -q_prim_vf(xibeg + 1)%sf(k, n - (j - 1), l) end if end do @@ -524,41 +463,35 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, n + j, l, q, i) = & - pb_in(k, n - (j - 1), l, q, i) - mv_in(k, n + j, l, q, i) = & - mv_in(k, n - (j - 1), l, q, i) + pb_in(k, n + j, l, q, i) = pb_in(k, n - (j - 1), l, q, i) + mv_in(k, n + j, l, q, i) = mv_in(k, n - (j - 1), l, q, i) end do end do end do end if end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do j = 1, buff_size do i = 1, momxb + 1 - q_prim_vf(i)%sf(k, l, -j) = & - q_prim_vf(i)%sf(k, l, j - 1) + q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, j - 1) end do - q_prim_vf(momxe)%sf(k, l, -j) = & - -q_prim_vf(momxe)%sf(k, l, j - 1) + q_prim_vf(momxe)%sf(k, l, -j) = -q_prim_vf(momxe)%sf(k, l, j - 1) do i = E_idx, sys_size - q_prim_vf(i)%sf(k, l, -j) = & - q_prim_vf(i)%sf(k, l, j - 1) + q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, j - 1) end do if (elasticity) then do i = 1, shear_BC_flip_num - q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, -j) = & - -q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, j - 1) + q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, -j) = -q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, & + & l, j - 1) end do end if if (hyperelasticity) then - q_prim_vf(xiend)%sf(k, l, -j) = & - -q_prim_vf(xiend)%sf(k, l, j - 1) + q_prim_vf(xiend)%sf(k, l, -j) = -q_prim_vf(xiend)%sf(k, l, j - 1) end if end do @@ -566,10 +499,8 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, l, -j, q, i) = & - pb_in(k, l, j - 1, q, i) - mv_in(k, l, -j, q, i) = & - mv_in(k, l, j - 1, q, i) + pb_in(k, l, -j, q, i) = pb_in(k, l, j - 1, q, i) + mv_in(k, l, -j, q, i) = mv_in(k, l, j - 1, q, i) end do end do end do @@ -577,28 +508,24 @@ contains else !< bc_z%end do j = 1, buff_size do i = 1, momxb + 1 - q_prim_vf(i)%sf(k, l, p + j) = & - q_prim_vf(i)%sf(k, l, p - (j - 1)) + q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p - (j - 1)) end do - q_prim_vf(momxe)%sf(k, l, p + j) = & - -q_prim_vf(momxe)%sf(k, l, p - (j - 1)) + q_prim_vf(momxe)%sf(k, l, p + j) = -q_prim_vf(momxe)%sf(k, l, p - (j - 1)) do i = E_idx, sys_size - q_prim_vf(i)%sf(k, l, p + j) = & - q_prim_vf(i)%sf(k, l, p - (j - 1)) + q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p - (j - 1)) end do if (elasticity) then do i = 1, shear_BC_flip_num - q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, p + j) = & - -q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, p - (j - 1)) + q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, p + j) = -q_prim_vf(shear_BC_flip_indices(3, & + & i))%sf(k, l, p - (j - 1)) end do end if if (hyperelasticity) then - q_prim_vf(xiend)%sf(k, l, p + j) = & - -q_prim_vf(xiend)%sf(k, l, p - (j - 1)) + q_prim_vf(xiend)%sf(k, l, p + j) = -q_prim_vf(xiend)%sf(k, l, p - (j - 1)) end if end do @@ -606,35 +533,29 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, l, p + j, q, i) = & - pb_in(k, l, p - (j - 1), q, i) - mv_in(k, l, p + j, q, i) = & - mv_in(k, l, p - (j - 1), q, i) + pb_in(k, l, p + j, q, i) = pb_in(k, l, p - (j - 1), q, i) + mv_in(k, l, p + j, q, i) = mv_in(k, l, p - (j - 1), q, i) end do end do end do end if end if end if - end subroutine s_symmetry - !> @brief Applies periodic boundary conditions by copying values from the opposite domain boundary. subroutine s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, q, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, q, i if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then !< bc_x%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(-j, k, l) = & - q_prim_vf(i)%sf(m - (j - 1), k, l) + q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l) end do end do @@ -642,10 +563,8 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(-j, k, l, q, i) = & - pb_in(m - (j - 1), k, l, q, i) - mv_in(-j, k, l, q, i) = & - mv_in(m - (j - 1), k, l, q, i) + pb_in(-j, k, l, q, i) = pb_in(m - (j - 1), k, l, q, i) + mv_in(-j, k, l, q, i) = mv_in(m - (j - 1), k, l, q, i) end do end do end do @@ -653,8 +572,7 @@ contains else !< bc_x%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(m + j, k, l) = & - q_prim_vf(i)%sf(j - 1, k, l) + q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(j - 1, k, l) end do end do @@ -662,21 +580,18 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(m + j, k, l, q, i) = & - pb_in(j - 1, k, l, q, i) - mv_in(m + j, k, l, q, i) = & - mv_in(j - 1, k, l, q, i) + pb_in(m + j, k, l, q, i) = pb_in(j - 1, k, l, q, i) + mv_in(m + j, k, l, q, i) = mv_in(j - 1, k, l, q, i) end do end do end do end if end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, n - (j - 1), l) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l) end do end do @@ -684,10 +599,8 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, -j, l, q, i) = & - pb_in(k, n - (j - 1), l, q, i) - mv_in(k, -j, l, q, i) = & - mv_in(k, n - (j - 1), l, q, i) + pb_in(k, -j, l, q, i) = pb_in(k, n - (j - 1), l, q, i) + mv_in(k, -j, l, q, i) = mv_in(k, n - (j - 1), l, q, i) end do end do end do @@ -695,8 +608,7 @@ contains else !< bc_y%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, n + j, l) = & - q_prim_vf(i)%sf(k, j - 1, l) + q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, j - 1, l) end do end do @@ -704,21 +616,18 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, n + j, l, q, i) = & - pb_in(k, (j - 1), l, q, i) - mv_in(k, n + j, l, q, i) = & - mv_in(k, (j - 1), l, q, i) + pb_in(k, n + j, l, q, i) = pb_in(k, (j - 1), l, q, i) + mv_in(k, n + j, l, q, i) = mv_in(k, (j - 1), l, q, i) end do end do end do end if end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, l, -j) = & - q_prim_vf(i)%sf(k, l, p - (j - 1)) + q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, p - (j - 1)) end do end do @@ -726,10 +635,8 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, l, -j, q, i) = & - pb_in(k, l, p - (j - 1), q, i) - mv_in(k, l, -j, q, i) = & - mv_in(k, l, p - (j - 1), q, i) + pb_in(k, l, -j, q, i) = pb_in(k, l, p - (j - 1), q, i) + mv_in(k, l, -j, q, i) = mv_in(k, l, p - (j - 1), q, i) end do end do end do @@ -737,8 +644,7 @@ contains else !< bc_z%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, l, p + j) = & - q_prim_vf(i)%sf(k, l, j - 1) + q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, j - 1) end do end do @@ -746,60 +652,48 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, l, p + j, q, i) = & - pb_in(k, l, j - 1, q, i) - mv_in(k, l, p + j, q, i) = & - mv_in(k, l, j - 1, q, i) + pb_in(k, l, p + j, q, i) = pb_in(k, l, j - 1, q, i) + mv_in(k, l, p + j, q, i) = mv_in(k, l, j - 1, q, i) end do end do end do end if end if end if - end subroutine s_periodic - - !> @brief Applies axis boundary conditions for cylindrical coordinates by reflecting values across the axis with azimuthal phase shift. + !> @brief Applies axis boundary conditions for cylindrical coordinates by reflecting values across the axis with azimuthal phase + !! shift. subroutine s_axis(q_prim_vf, pb_in, mv_in, k, l) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: k, l - - integer :: j, q, i + integer, intent(in) :: k, l + integer :: j, q, i do j = 1, buff_size if (z_cc(l) < pi) then do i = 1, momxb - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, j - 1, l + ((p + 1)/2)) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l + ((p + 1)/2)) end do - q_prim_vf(momxb + 1)%sf(k, -j, l) = & - -q_prim_vf(momxb + 1)%sf(k, j - 1, l + ((p + 1)/2)) + q_prim_vf(momxb + 1)%sf(k, -j, l) = -q_prim_vf(momxb + 1)%sf(k, j - 1, l + ((p + 1)/2)) - q_prim_vf(momxe)%sf(k, -j, l) = & - -q_prim_vf(momxe)%sf(k, j - 1, l + ((p + 1)/2)) + q_prim_vf(momxe)%sf(k, -j, l) = -q_prim_vf(momxe)%sf(k, j - 1, l + ((p + 1)/2)) do i = E_idx, sys_size - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, j - 1, l + ((p + 1)/2)) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l + ((p + 1)/2)) end do else do i = 1, momxb - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, j - 1, l - ((p + 1)/2)) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l - ((p + 1)/2)) end do - q_prim_vf(momxb + 1)%sf(k, -j, l) = & - -q_prim_vf(momxb + 1)%sf(k, j - 1, l - ((p + 1)/2)) + q_prim_vf(momxb + 1)%sf(k, -j, l) = -q_prim_vf(momxb + 1)%sf(k, j - 1, l - ((p + 1)/2)) - q_prim_vf(momxe)%sf(k, -j, l) = & - -q_prim_vf(momxe)%sf(k, j - 1, l - ((p + 1)/2)) + q_prim_vf(momxe)%sf(k, -j, l) = -q_prim_vf(momxe)%sf(k, j - 1, l - ((p + 1)/2)) do i = E_idx, sys_size - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, j - 1, l - ((p + 1)/2)) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l - ((p + 1)/2)) end do end if end do @@ -808,37 +702,29 @@ contains do i = 1, nb do q = 1, nnode do j = 1, buff_size - pb_in(k, -j, l, q, i) = & - pb_in(k, j - 1, l - ((p + 1)/2), q, i) - mv_in(k, -j, l, q, i) = & - mv_in(k, j - 1, l - ((p + 1)/2), q, i) + pb_in(k, -j, l, q, i) = pb_in(k, j - 1, l - ((p + 1)/2), q, i) + mv_in(k, -j, l, q, i) = mv_in(k, j - 1, l - ((p + 1)/2), q, i) end do end do end do end if - end subroutine s_axis - !> @brief Applies slip wall boundary conditions by extrapolating scalars and reflecting the wall-normal velocity component. subroutine s_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l) - $:GPU_ROUTINE(function_name='s_slip_wall',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_slip_wall',parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, i if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then !< bc_x%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb) then - q_prim_vf(i)%sf(-j, k, l) = & - -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb1 + q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb1 else - q_prim_vf(i)%sf(-j, k, l) = & - q_prim_vf(i)%sf(0, k, l) + q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l) end if end do end do @@ -846,25 +732,21 @@ contains do i = 1, sys_size do j = 1, buff_size if (i == momxb) then - q_prim_vf(i)%sf(m + j, k, l) = & - -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve1 + q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve1 else - q_prim_vf(i)%sf(m + j, k, l) = & - q_prim_vf(i)%sf(m, k, l) + q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l) end if end do end do end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb + 1) then - q_prim_vf(i)%sf(k, -j, l) = & - -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb2 + q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb2 else - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, 0, l) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l) end if end do end do @@ -872,25 +754,21 @@ contains do i = 1, sys_size do j = 1, buff_size if (i == momxb + 1) then - q_prim_vf(i)%sf(k, n + j, l) = & - -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve2 + q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve2 else - q_prim_vf(i)%sf(k, n + j, l) = & - q_prim_vf(i)%sf(k, n, l) + q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l) end if end do end do end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size if (i == momxe) then - q_prim_vf(i)%sf(k, l, -j) = & - -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb3 + q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb3 else - q_prim_vf(i)%sf(k, l, -j) = & - q_prim_vf(i)%sf(k, l, 0) + q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0) end if end do end do @@ -898,46 +776,36 @@ contains do i = 1, sys_size do j = 1, buff_size if (i == momxe) then - q_prim_vf(i)%sf(k, l, p + j) = & - -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve3 + q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve3 else - q_prim_vf(i)%sf(k, l, p + j) = & - q_prim_vf(i)%sf(k, l, p) + q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p) end if end do end do end if end if - end subroutine s_slip_wall - !> @brief Applies no-slip wall boundary conditions by reflecting and negating all velocity components at the wall. subroutine s_no_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l) - $:GPU_ROUTINE(function_name='s_no_slip_wall',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_no_slip_wall',parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, i if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then !< bc_x%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb) then - q_prim_vf(i)%sf(-j, k, l) = & - -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb1 - elseif (i == momxb + 1 .and. num_dims > 1) then - q_prim_vf(i)%sf(-j, k, l) = & - -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb2 - elseif (i == momxb + 2 .and. num_dims > 2) then - q_prim_vf(i)%sf(-j, k, l) = & - -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb3 + q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb1 + else if (i == momxb + 1 .and. num_dims > 1) then + q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb2 + else if (i == momxb + 2 .and. num_dims > 2) then + q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb3 else - q_prim_vf(i)%sf(-j, k, l) = & - q_prim_vf(i)%sf(0, k, l) + q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l) end if end do end do @@ -945,37 +813,29 @@ contains do i = 1, sys_size do j = 1, buff_size if (i == momxb) then - q_prim_vf(i)%sf(m + j, k, l) = & - -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve1 - elseif (i == momxb + 1 .and. num_dims > 1) then - q_prim_vf(i)%sf(m + j, k, l) = & - -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve2 - elseif (i == momxb + 2 .and. num_dims > 2) then - q_prim_vf(i)%sf(m + j, k, l) = & - -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve3 + q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve1 + else if (i == momxb + 1 .and. num_dims > 1) then + q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve2 + else if (i == momxb + 2 .and. num_dims > 2) then + q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve3 else - q_prim_vf(i)%sf(m + j, k, l) = & - q_prim_vf(i)%sf(m, k, l) + q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l) end if end do end do end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb) then - q_prim_vf(i)%sf(k, -j, l) = & - -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb1 - elseif (i == momxb + 1 .and. num_dims > 1) then - q_prim_vf(i)%sf(k, -j, l) = & - -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb2 - elseif (i == momxb + 2 .and. num_dims > 2) then - q_prim_vf(i)%sf(k, -j, l) = & - -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb3 + q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb1 + else if (i == momxb + 1 .and. num_dims > 1) then + q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb2 + else if (i == momxb + 2 .and. num_dims > 2) then + q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb3 else - q_prim_vf(i)%sf(k, -j, l) = & - q_prim_vf(i)%sf(k, 0, l) + q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l) end if end do end do @@ -983,37 +843,29 @@ contains do i = 1, sys_size do j = 1, buff_size if (i == momxb) then - q_prim_vf(i)%sf(k, n + j, l) = & - -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve1 - elseif (i == momxb + 1 .and. num_dims > 1) then - q_prim_vf(i)%sf(k, n + j, l) = & - -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve2 - elseif (i == momxb + 2 .and. num_dims > 2) then - q_prim_vf(i)%sf(k, n + j, l) = & - -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve3 + q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve1 + else if (i == momxb + 1 .and. num_dims > 1) then + q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve2 + else if (i == momxb + 2 .and. num_dims > 2) then + q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve3 else - q_prim_vf(i)%sf(k, n + j, l) = & - q_prim_vf(i)%sf(k, n, l) + q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l) end if end do end do end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb) then - q_prim_vf(i)%sf(k, l, -j) = & - -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb1 - elseif (i == momxb + 1 .and. num_dims > 1) then - q_prim_vf(i)%sf(k, l, -j) = & - -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb2 - elseif (i == momxb + 2 .and. num_dims > 2) then - q_prim_vf(i)%sf(k, l, -j) = & - -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb3 + q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb1 + else if (i == momxb + 1 .and. num_dims > 1) then + q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb2 + else if (i == momxb + 2 .and. num_dims > 2) then + q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb3 else - q_prim_vf(i)%sf(k, l, -j) = & - q_prim_vf(i)%sf(k, l, 0) + q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0) end if end do end do @@ -1021,84 +873,70 @@ contains do i = 1, sys_size do j = 1, buff_size if (i == momxb) then - q_prim_vf(i)%sf(k, l, p + j) = & - -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve1 - elseif (i == momxb + 1 .and. num_dims > 1) then - q_prim_vf(i)%sf(k, l, p + j) = & - -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve2 - elseif (i == momxb + 2 .and. num_dims > 2) then - q_prim_vf(i)%sf(k, l, p + j) = & - -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve3 + q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve1 + else if (i == momxb + 1 .and. num_dims > 1) then + q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve2 + else if (i == momxb + 2 .and. num_dims > 2) then + q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve3 else - q_prim_vf(i)%sf(k, l, p + j) = & - q_prim_vf(i)%sf(k, l, p) + q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p) end if end do end do end if end if - end subroutine s_no_slip_wall - !> @brief Applies Dirichlet boundary conditions by prescribing ghost cell values from stored boundary buffers. subroutine s_dirichlet(q_prim_vf, bc_dir, bc_loc, k, l) - $:GPU_ROUTINE(function_name='s_dirichlet',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_dirichlet',parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, i #ifdef MFC_SIMULATION if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !bc_x%beg + if (bc_loc == -1) then ! bc_x%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(-j, k, l) = & - bc_buffers(1, 1)%sf(i, k, l) + q_prim_vf(i)%sf(-j, k, l) = bc_buffers(1, 1)%sf(i, k, l) end do end do else !< bc_x%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(m + j, k, l) = & - bc_buffers(1, 2)%sf(i, k, l) + q_prim_vf(i)%sf(m + j, k, l) = bc_buffers(1, 2)%sf(i, k, l) end do end do end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, -j, l) = & - bc_buffers(2, 1)%sf(k, i, l) + q_prim_vf(i)%sf(k, -j, l) = bc_buffers(2, 1)%sf(k, i, l) end do end do else !< bc_y%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, n + j, l) = & - bc_buffers(2, 2)%sf(k, i, l) + q_prim_vf(i)%sf(k, n + j, l) = bc_buffers(2, 2)%sf(k, i, l) end do end do end if #:endif - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, l, -j) = & - bc_buffers(3, 1)%sf(k, l, i) + q_prim_vf(i)%sf(k, l, -j) = bc_buffers(3, 1)%sf(k, l, i) end do end do else !< bc_z%end do i = 1, sys_size do j = 1, buff_size - q_prim_vf(i)%sf(k, l, p + j) = & - bc_buffers(3, 2)%sf(k, l, i) + q_prim_vf(i)%sf(k, l, p + j) = bc_buffers(3, 2)%sf(k, l, i) end do end do end if @@ -1107,20 +945,17 @@ contains #else call s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l) #endif - end subroutine s_dirichlet - !> @brief Extrapolates QBMM bubble pressure and mass-vapor variables into ghost cells by copying boundary values. subroutine s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, q, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, q, i if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !bc_x%beg + if (bc_loc == -1) then ! bc_x%beg do i = 1, nb do q = 1, nnode do j = 1, buff_size @@ -1139,7 +974,7 @@ contains end do end do end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do i = 1, nb do q = 1, nnode @@ -1159,7 +994,7 @@ contains end do end do end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do i = 1, nb do q = 1, nnode @@ -1180,22 +1015,18 @@ contains end do end if end if - end subroutine s_qbmm_extrapolation - !> @brief Populates ghost cell buffers for the color function and its divergence used in capillary surface tension. impure subroutine s_populate_capillary_buffers(c_divs, bc_type) - - type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs + type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - - integer :: k, l + integer :: k, l !< x-direction if (bc_x%beg >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 1, -1, num_dims + 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = 0, n select case (bc_type(1, 1)%sf(0, k, l)) @@ -1214,7 +1045,7 @@ contains if (bc_x%end >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 1, 1, num_dims + 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = 0, n select case (bc_type(1, 2)%sf(0, k, l)) @@ -1233,12 +1064,11 @@ contains if (n == 0) return #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - !< y-direction if (bc_y%beg >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 2, -1, num_dims + 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = -buff_size, m + buff_size select case (bc_type(2, 1)%sf(k, 0, l)) @@ -1257,7 +1087,7 @@ contains if (bc_y%end >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 2, 1, num_dims + 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = -buff_size, m + buff_size select case (bc_type(2, 2)%sf(k, 0, l)) @@ -1272,7 +1102,6 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - #:endif if (p == 0) return @@ -1282,7 +1111,7 @@ contains if (bc_z%beg >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 3, -1, num_dims + 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size select case (bc_type(3, 1)%sf(k, l, 0)) @@ -1301,7 +1130,7 @@ contains if (bc_z%end >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 3, 1, num_dims + 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = -buff_size, n + buff_size do k = -buff_size, m + buff_size select case (bc_type(3, 2)%sf(k, l, 0)) @@ -1318,19 +1147,16 @@ contains end if #:endif end subroutine s_populate_capillary_buffers - !> @brief Applies periodic boundary conditions to the color function and its divergence fields. subroutine s_color_function_periodic(c_divs, bc_dir, bc_loc, k, l) - $:GPU_ROUTINE(function_name='s_color_function_periodic', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_color_function_periodic', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, i if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !bc_x%beg + if (bc_loc == -1) then ! bc_x%beg do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(m - (j - 1), k, l) @@ -1343,7 +1169,7 @@ contains end do end do end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do i = 1, num_dims + 1 do j = 1, buff_size @@ -1357,7 +1183,7 @@ contains end do end do end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do i = 1, num_dims + 1 do j = 1, buff_size @@ -1372,21 +1198,17 @@ contains end do end if end if - end subroutine s_color_function_periodic - !> @brief Applies reflective boundary conditions to the color function and its divergence fields. subroutine s_color_function_reflective(c_divs, bc_dir, bc_loc, k, l) - $:GPU_ROUTINE(function_name='s_color_function_reflective', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_color_function_reflective', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, i if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !bc_x%beg + if (bc_loc == -1) then ! bc_x%beg do i = 1, num_dims + 1 do j = 1, buff_size if (i == bc_dir) then @@ -1407,7 +1229,7 @@ contains end do end do end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do i = 1, num_dims + 1 do j = 1, buff_size @@ -1429,7 +1251,7 @@ contains end do end do end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do i = 1, num_dims + 1 do j = 1, buff_size @@ -1452,21 +1274,17 @@ contains end do end if end if - end subroutine s_color_function_reflective - !> @brief Extrapolates the color function and its divergence into ghost cells by copying boundary values. subroutine s_color_function_ghost_cell_extrapolation(c_divs, bc_dir, bc_loc, k, l) - $:GPU_ROUTINE(function_name='s_color_function_ghost_cell_extrapolation', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_color_function_ghost_cell_extrapolation', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - - integer :: j, i + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, i if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !bc_x%beg + if (bc_loc == -1) then ! bc_x%beg do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(0, k, l) @@ -1479,7 +1297,7 @@ contains end do end do end if - elseif (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction if (bc_loc == -1) then !< bc_y%beg do i = 1, num_dims + 1 do j = 1, buff_size @@ -1493,7 +1311,7 @@ contains end do end do end if - elseif (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction if (bc_loc == -1) then !< bc_z%beg do i = 1, num_dims + 1 do j = 1, buff_size @@ -1508,21 +1326,17 @@ contains end do end if end if - end subroutine s_color_function_ghost_cell_extrapolation - !> @brief Populates ghost cell buffers for the Jacobian scalar field used in the IGR elliptic solver. impure subroutine s_populate_F_igr_buffers(bc_type, jac_sf) - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - type(scalar_field), dimension(1:), intent(inout) :: jac_sf - - integer :: j, k, l + type(scalar_field), dimension(1:), intent(inout) :: jac_sf + integer :: j, k, l if (bc_x%beg >= 0) then call s_mpi_sendrecv_variables_buffers(jac_sf, 1, -1, 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = 0, n select case (bc_type(1, 1)%sf(0, k, l)) @@ -1542,13 +1356,12 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end if if (bc_x%end >= 0) then call s_mpi_sendrecv_variables_buffers(jac_sf, 1, 1, 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = 0, n select case (bc_type(1, 2)%sf(0, k, l)) @@ -1568,17 +1381,15 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end if #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (n == 0) then return else if (bc_y%beg >= 0) then call s_mpi_sendrecv_variables_buffers(jac_sf, 2, -1, 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = idwbuff(1)%beg, idwbuff(1)%end select case (bc_type(2, 1)%sf(k, 0, l)) @@ -1598,13 +1409,12 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end if if (bc_y%end >= 0) then call s_mpi_sendrecv_variables_buffers(jac_sf, 2, 1, 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = 0, p do k = idwbuff(1)%beg, idwbuff(1)%end select case (bc_type(2, 2)%sf(k, 0, l)) @@ -1625,7 +1435,6 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - #:endif #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 @@ -1634,7 +1443,7 @@ contains else if (bc_z%beg >= 0) then call s_mpi_sendrecv_variables_buffers(jac_sf, 3, -1, 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = idwbuff(2)%beg, idwbuff(2)%end do k = idwbuff(1)%beg, idwbuff(1)%end select case (bc_type(3, 1)%sf(k, l, 0)) @@ -1659,7 +1468,7 @@ contains if (bc_z%end >= 0) then call s_mpi_sendrecv_variables_buffers(jac_sf, 3, 1, 1) else - $:GPU_PARALLEL_LOOP(private='[l,k]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[l, k]', collapse=2) do l = idwbuff(2)%beg, idwbuff(2)%end do k = idwbuff(1)%beg, idwbuff(1)%end select case (bc_type(3, 2)%sf(k, l, 0)) @@ -1682,24 +1491,22 @@ contains end if #:endif end subroutine s_populate_F_igr_buffers - !> @brief Creates MPI derived datatypes for boundary condition type arrays and buffer arrays used in parallel I/O. impure subroutine s_create_mpi_types(bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type #ifdef MFC_MPI - integer :: dir, loc + integer :: dir, loc integer, dimension(3) :: sf_start_idx, sf_extents_loc - integer :: ierr + integer :: ierr do dir = 1, num_dims do loc = 1, 2 sf_start_idx = (/0, 0, 0/) sf_extents_loc = shape(bc_type(dir, loc)%sf) - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sf_extents_loc, sf_extents_loc, sf_start_idx, & - MPI_ORDER_FORTRAN, MPI_INTEGER, MPI_BC_TYPE_TYPE(dir, loc), ierr) + call MPI_TYPE_CREATE_SUBARRAY(num_dims, sf_extents_loc, sf_extents_loc, sf_start_idx, MPI_ORDER_FORTRAN, & + & MPI_INTEGER, MPI_BC_TYPE_TYPE(dir, loc), ierr) call MPI_TYPE_COMMIT(MPI_BC_TYPE_TYPE(dir, loc), ierr) end do end do @@ -1710,26 +1517,21 @@ contains sf_extents_loc = shape(bc_buffers(dir, loc)%sf) call MPI_TYPE_CREATE_SUBARRAY(num_dims, sf_extents_loc*mpi_io_type, sf_extents_loc*mpi_io_type, sf_start_idx, & - MPI_ORDER_FORTRAN, mpi_io_p, MPI_BC_BUFFER_TYPE(dir, loc), ierr) + & MPI_ORDER_FORTRAN, mpi_io_p, MPI_BC_BUFFER_TYPE(dir, loc), ierr) call MPI_TYPE_COMMIT(MPI_BC_BUFFER_TYPE(dir, loc), ierr) end do end do #endif end subroutine s_create_mpi_types - !> @brief Writes boundary condition type and buffer data to serial (unformatted) restart files. subroutine s_write_serial_boundary_condition_files(q_prim_vf, bc_type, step_dirpath, old_grid_in) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - logical, intent(in) :: old_grid_in - - character(LEN=*), intent(in) :: step_dirpath - - integer :: dir, loc, i - character(len=path_len) :: file_path - - character(len=10) :: status + logical, intent(in) :: old_grid_in + character(LEN=*), intent(in) :: step_dirpath + integer :: dir, loc, i + character(len=path_len) :: file_path + character(len=10) :: status if (old_grid_in) then status = 'old' @@ -1739,8 +1541,8 @@ contains call s_pack_boundary_condition_buffers(q_prim_vf) - file_path = trim(step_dirpath)//'/bc_type.dat' - open (1, FILE=trim(file_path), FORM='unformatted', STATUS=status) + file_path = trim(step_dirpath) // '/bc_type.dat' + open (1, FILE=trim(file_path), form='unformatted', STATUS=status) do dir = 1, num_dims do loc = 1, 2 write (1) bc_type(dir, loc)%sf @@ -1748,39 +1550,34 @@ contains end do close (1) - file_path = trim(step_dirpath)//'/bc_buffers.dat' - open (1, FILE=trim(file_path), FORM='unformatted', STATUS=status) + file_path = trim(step_dirpath) // '/bc_buffers.dat' + open (1, FILE=trim(file_path), form='unformatted', STATUS=status) do dir = 1, num_dims do loc = 1, 2 write (1) bc_buffers(dir, loc)%sf end do end do close (1) - end subroutine s_write_serial_boundary_condition_files - !> @brief Writes boundary condition type and buffer data to per-rank parallel files using MPI I/O. subroutine s_write_parallel_boundary_condition_files(q_prim_vf, bc_type) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - - integer :: dir, loc - character(len=path_len) :: file_loc, file_path - - character(len=10) :: status + integer :: dir, loc + character(len=path_len) :: file_loc, file_path + character(len=10) :: status #ifdef MFC_MPI - integer :: ierr - integer :: file_id - integer :: offset + integer :: ierr + integer :: file_id + integer :: offset character(len=7) :: proc_rank_str - logical :: dir_check - integer :: nelements + logical :: dir_check + integer :: nelements call s_pack_boundary_condition_buffers(q_prim_vf) - file_loc = trim(case_dir)//'/restart_data/boundary_conditions' + file_loc = trim(case_dir) // '/restart_data/boundary_conditions' if (proc_rank == 0) then call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then @@ -1795,7 +1592,7 @@ contains call DelayFileAccess(proc_rank) write (proc_rank_str, '(I7.7)') proc_rank - file_path = trim(file_loc)//'/bc_'//trim(proc_rank_str)//'.dat' + file_path = trim(file_loc) // '/bc_' // trim(proc_rank_str) // '.dat' call MPI_File_open(MPI_COMM_SELF, trim(file_path), MPI_MODE_CREATE + MPI_MODE_WRONLY, MPI_INFO_NULL, file_id, ierr) offset = 0 @@ -1823,30 +1620,24 @@ contains call MPI_File_close(file_id, ierr) #endif - end subroutine s_write_parallel_boundary_condition_files - !> @brief Reads boundary condition type and buffer data from serial (unformatted) restart files. subroutine s_read_serial_boundary_condition_files(step_dirpath, bc_type) - - character(LEN=*), intent(in) :: step_dirpath - + character(LEN=*), intent(in) :: step_dirpath type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - - integer :: dir, loc - logical :: file_exist - character(len=path_len) :: file_path - - character(len=10) :: status + integer :: dir, loc + logical :: file_exist + character(len=path_len) :: file_path + character(len=10) :: status ! Read bc_types - file_path = trim(step_dirpath)//'/bc_type.dat' + file_path = trim(step_dirpath) // '/bc_type.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (.not. file_exist) then - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if - open (1, FILE=trim(file_path), FORM='unformatted', STATUS='unknown') + open (1, FILE=trim(file_path), form='unformatted', STATUS='unknown') do dir = 1, num_dims do loc = 1, 2 read (1) bc_type(dir, loc)%sf @@ -1856,13 +1647,13 @@ contains close (1) ! Read bc_buffers - file_path = trim(step_dirpath)//'/bc_buffers.dat' + file_path = trim(step_dirpath) // '/bc_buffers.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (.not. file_exist) then - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if - open (1, FILE=trim(file_path), FORM='unformatted', STATUS='unknown') + open (1, FILE=trim(file_path), form='unformatted', STATUS='unknown') do dir = 1, num_dims do loc = 1, 2 read (1) bc_buffers(dir, loc)%sf @@ -1870,33 +1661,28 @@ contains end do end do close (1) - end subroutine s_read_serial_boundary_condition_files - !> @brief Reads boundary condition type and buffer data from per-rank parallel files using MPI I/O. subroutine s_read_parallel_boundary_condition_files(bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - - integer :: dir, loc - character(len=path_len) :: file_loc, file_path - - character(len=10) :: status + integer :: dir, loc + character(len=path_len) :: file_loc, file_path + character(len=10) :: status #ifdef MFC_MPI - integer :: ierr - integer :: file_id - integer :: offset + integer :: ierr + integer :: file_id + integer :: offset character(len=7) :: proc_rank_str - logical :: dir_check - integer :: nelements + logical :: dir_check + integer :: nelements - file_loc = trim(case_dir)//'/restart_data/boundary_conditions' + file_loc = trim(case_dir) // '/restart_data/boundary_conditions' if (proc_rank == 0) then call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then - call s_mpi_abort(trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort(trim(file_loc) // ' is missing. Exiting.') end if end if @@ -1907,7 +1693,7 @@ contains call DelayFileAccess(proc_rank) write (proc_rank_str, '(I7.7)') proc_rank - file_path = trim(file_loc)//'/bc_'//trim(proc_rank_str)//'.dat' + file_path = trim(file_loc) // '/bc_' // trim(proc_rank_str) // '.dat' call MPI_File_open(MPI_COMM_SELF, trim(file_path), MPI_MODE_RDONLY, MPI_INFO_NULL, file_id, ierr) offset = 0 @@ -1937,14 +1723,11 @@ contains call MPI_File_close(file_id, ierr) #endif - end subroutine s_read_parallel_boundary_condition_files - !> @brief Packs primitive variable boundary slices into bc_buffers arrays for serialization. subroutine s_pack_boundary_condition_buffers(q_prim_vf) - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer :: i, j, k + integer :: i, j, k do k = 0, p do j = 0, n @@ -1956,7 +1739,6 @@ contains end do #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (n > 0) then do k = 0, p do j = 1, sys_size @@ -1968,7 +1750,6 @@ contains end do #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (p > 0) then do k = 1, sys_size do j = 0, n @@ -1979,46 +1760,36 @@ contains end do end do end if - #:endif end if - #:endif - end subroutine s_pack_boundary_condition_buffers - !> @brief Initializes the per-cell boundary condition type arrays with the global default BC values. subroutine s_assign_default_bc_type(bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - bc_type(1, 1)%sf(:, :, :) = int(min(bc_x%beg, 0), kind=1) - bc_type(1, 2)%sf(:, :, :) = int(min(bc_x%end, 0), kind=1) - $:GPU_UPDATE(device='[bc_type(1,1)%sf,bc_type(1,2)%sf]') + bc_type(1, 1)%sf(:,:,:) = int(min(bc_x%beg, 0), kind=1) + bc_type(1, 2)%sf(:,:,:) = int(min(bc_x%end, 0), kind=1) + $:GPU_UPDATE(device='[bc_type(1, 1)%sf, bc_type(1, 2)%sf]') #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 if (n > 0) then - bc_type(2, 1)%sf(:, :, :) = int(min(bc_y%beg, 0), kind=1) - bc_type(2, 2)%sf(:, :, :) = int(min(bc_y%end, 0), kind=1) - $:GPU_UPDATE(device='[bc_type(2,1)%sf,bc_type(2,2)%sf]') + bc_type(2, 1)%sf(:,:,:) = int(min(bc_y%beg, 0), kind=1) + bc_type(2, 2)%sf(:,:,:) = int(min(bc_y%end, 0), kind=1) + $:GPU_UPDATE(device='[bc_type(2, 1)%sf, bc_type(2, 2)%sf]') #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 if (p > 0) then - bc_type(3, 1)%sf(:, :, :) = int(min(bc_z%beg, 0), kind=1) - bc_type(3, 2)%sf(:, :, :) = int(min(bc_z%end, 0), kind=1) - $:GPU_UPDATE(device='[bc_type(3,1)%sf,bc_type(3,2)%sf]') + bc_type(3, 1)%sf(:,:,:) = int(min(bc_z%beg, 0), kind=1) + bc_type(3, 2)%sf(:,:,:) = int(min(bc_z%end, 0), kind=1) + $:GPU_UPDATE(device='[bc_type(3, 1)%sf, bc_type(3, 2)%sf]') end if #:endif end if #:endif - end subroutine s_assign_default_bc_type - - !> The purpose of this subroutine is to populate the buffers - !! of the grid variables, which are constituted of the cell- - !! boundary locations and cell-width distributions, based on - !! the boundary conditions. + !> The purpose of this subroutine is to populate the buffers of the grid variables, which are constituted of the cell- boundary + !! locations and cell-width distributions, based on the boundary conditions. subroutine s_populate_grid_variables_buffers - integer :: i !< Generic loop iterator #ifdef MFC_SIMULATION @@ -2035,15 +1806,15 @@ contains ! Populating cell-width distribution buffer at bc_x%beg if (bc_x%beg >= 0) then call s_mpi_sendrecv_grid_variables_buffers(1, -1) - elseif (bc_x%beg <= BC_GHOST_EXTRAP) then + else if (bc_x%beg <= BC_GHOST_EXTRAP) then do i = 1, buff_size dx(-i) = dx(0) end do - elseif (bc_x%beg == BC_REFLECTIVE) then + else if (bc_x%beg == BC_REFLECTIVE) then do i = 1, buff_size dx(-i) = dx(i - 1) end do - elseif (bc_x%beg == BC_PERIODIC) then + else if (bc_x%beg == BC_PERIODIC) then do i = 1, buff_size dx(-i) = dx(m - (i - 1)) end do @@ -2061,15 +1832,15 @@ contains ! Populating the cell-width distribution buffer at bc_x%end if (bc_x%end >= 0) then call s_mpi_sendrecv_grid_variables_buffers(1, 1) - elseif (bc_x%end <= BC_GHOST_EXTRAP) then + else if (bc_x%end <= BC_GHOST_EXTRAP) then do i = 1, buff_size dx(m + i) = dx(m) end do - elseif (bc_x%end == BC_REFLECTIVE) then + else if (bc_x%end == BC_REFLECTIVE) then do i = 1, buff_size dx(m + i) = dx(m - (i - 1)) end do - elseif (bc_x%end == BC_PERIODIC) then + else if (bc_x%end == BC_PERIODIC) then do i = 1, buff_size dx(m + i) = dx(i - 1) end do @@ -2090,17 +1861,17 @@ contains ! Populating cell-width distribution buffer at bc_y%beg if (n == 0) then return - elseif (bc_y%beg >= 0) then + else if (bc_y%beg >= 0) then call s_mpi_sendrecv_grid_variables_buffers(2, -1) - elseif (bc_y%beg <= BC_GHOST_EXTRAP .and. bc_y%beg /= BC_AXIS) then + else if (bc_y%beg <= BC_GHOST_EXTRAP .and. bc_y%beg /= BC_AXIS) then do i = 1, buff_size dy(-i) = dy(0) end do - elseif (bc_y%beg == BC_REFLECTIVE .or. bc_y%beg == BC_AXIS) then + else if (bc_y%beg == BC_REFLECTIVE .or. bc_y%beg == BC_AXIS) then do i = 1, buff_size dy(-i) = dy(i - 1) end do - elseif (bc_y%beg == BC_PERIODIC) then + else if (bc_y%beg == BC_PERIODIC) then do i = 1, buff_size dy(-i) = dy(n - (i - 1)) end do @@ -2118,15 +1889,15 @@ contains ! Populating the cell-width distribution buffer at bc_y%end if (bc_y%end >= 0) then call s_mpi_sendrecv_grid_variables_buffers(2, 1) - elseif (bc_y%end <= BC_GHOST_EXTRAP) then + else if (bc_y%end <= BC_GHOST_EXTRAP) then do i = 1, buff_size dy(n + i) = dy(n) end do - elseif (bc_y%end == BC_REFLECTIVE) then + else if (bc_y%end == BC_REFLECTIVE) then do i = 1, buff_size dy(n + i) = dy(n - (i - 1)) end do - elseif (bc_y%end == BC_PERIODIC) then + else if (bc_y%end == BC_PERIODIC) then do i = 1, buff_size dy(n + i) = dy(i - 1) end do @@ -2147,17 +1918,17 @@ contains ! Populating cell-width distribution buffer at bc_z%beg if (p == 0) then return - elseif (Bc_z%beg >= 0) then + else if (Bc_z%beg >= 0) then call s_mpi_sendrecv_grid_variables_buffers(3, -1) - elseif (bc_z%beg <= BC_GHOST_EXTRAP) then + else if (bc_z%beg <= BC_GHOST_EXTRAP) then do i = 1, buff_size dz(-i) = dz(0) end do - elseif (bc_z%beg == BC_REFLECTIVE) then + else if (bc_z%beg == BC_REFLECTIVE) then do i = 1, buff_size dz(-i) = dz(i - 1) end do - elseif (bc_z%beg == BC_PERIODIC) then + else if (bc_z%beg == BC_PERIODIC) then do i = 1, buff_size dz(-i) = dz(p - (i - 1)) end do @@ -2175,15 +1946,15 @@ contains ! Populating the cell-width distribution buffer at bc_z%end if (bc_z%end >= 0) then call s_mpi_sendrecv_grid_variables_buffers(3, 1) - elseif (bc_z%end <= BC_GHOST_EXTRAP) then + else if (bc_z%end <= BC_GHOST_EXTRAP) then do i = 1, buff_size dz(p + i) = dz(p) end do - elseif (bc_z%end == BC_REFLECTIVE) then + else if (bc_z%end == BC_REFLECTIVE) then do i = 1, buff_size dz(p + i) = dz(p - (i - 1)) end do - elseif (bc_z%end == BC_PERIODIC) then + else if (bc_z%end == BC_PERIODIC) then do i = 1, buff_size dz(p + i) = dz(i - 1) end do @@ -2198,14 +1969,10 @@ contains z_cc(p + i) = z_cc(p + (i - 1)) + (dz(p + (i - 1)) + dz(p + i))/2._wp end do ! END: Population of Buffers in z-direction - #endif - end subroutine s_populate_grid_variables_buffers - !> @brief Deallocates boundary condition buffer arrays allocated during module initialization. subroutine s_finalize_boundary_common_module() - if (bc_io) then deallocate (bc_buffers(1, 1)%sf) deallocate (bc_buffers(1, 2)%sf) @@ -2224,7 +1991,5 @@ contains end if deallocate (bc_buffers) - end subroutine s_finalize_boundary_common_module - end module m_boundary_common diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index 2280828a3a..38907b380f 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -7,7 +7,6 @@ !> @brief Shared input validation checks for grid dimensions and AMD GPU compiler limits module m_checker_common - use m_global_parameters !< Definitions of the global parameters use m_mpi_proxy !< Message passing interface (MPI) module proxy @@ -19,52 +18,39 @@ module m_checker_common implicit none private; public :: s_check_inputs_common, wp - contains - !> Checks compatibility of parameters in the input file. - !! Used by all three stages + !> Checks compatibility of parameters in the input file. Used by all three stages impure subroutine s_check_inputs_common - #ifndef MFC_SIMULATION call s_check_total_cells #endif #:if USING_AMD call s_check_amd #:endif - end subroutine s_check_inputs_common - #ifndef MFC_SIMULATION !> @brief Verifies that the total number of grid cells meets the minimum required by the number of dimensions and MPI ranks. impure subroutine s_check_total_cells character(len=18) :: numStr !< for int to string conversion - integer(kind=8) :: min_cells + integer(kind=8) :: min_cells min_cells = int(2, kind=8)**int(min(1, m) + min(1, n) + min(1, p), kind=8)*int(num_procs, kind=8) call s_int_to_str(2**(min(1, m) + min(1, n) + min(1, p))*num_procs, numStr) - @:PROHIBIT(nGlobal < min_cells, & - "Total number of cells must be at least (2^[number of dimensions])*num_procs, " // & - "which is currently "//trim(numStr)) + @:PROHIBIT(nGlobal < min_cells, "Total number of cells must be at least (2^[number of dimensions])*num_procs, " // "which is currently "//trim(numStr)) end subroutine s_check_total_cells - #endif !> @brief Checks that simulation parameters stay within AMD GPU compiler limits when case optimization is disabled. impure subroutine s_check_amd - #:if not MFC_CASE_OPTIMIZATION @:PROHIBIT(num_fluids > 3, "num_fluids <= 3 for AMDFLang when Case optimization is off") @:PROHIBIT((bubbles_euler .or. bubbles_lagrange) .and. nb > 3, "nb <= 3 for AMDFLang when Case optimization is off") @:PROHIBIT(chemistry .and. num_species /= 10, "num_species = 10 for AMDFLang when Case optimization is off") #:endif - end subroutine s_check_amd - #ifndef MFC_POST_PROCESS - #endif - end module m_checker_common diff --git a/src/common/m_chemistry.fpp b/src/common/m_chemistry.fpp index d7ffbc3cfe..584c121f7a 100644 --- a/src/common/m_chemistry.fpp +++ b/src/common/m_chemistry.fpp @@ -8,22 +8,18 @@ !> @brief Multi-species chemistry interface for thermodynamic properties, reaction rates, and transport coefficients module m_chemistry - - use m_thermochem, only: & - num_species, molecular_weights, get_temperature, get_net_production_rates, & - get_mole_fractions, get_species_binary_mass_diffusivities, & - get_species_mass_diffusivities_mixavg, gas_constant, get_mixture_molecular_weight, & - get_mixture_energy_mass, get_mixture_thermal_conductivity_mixavg, get_species_enthalpies_rt, & - get_mixture_viscosity_mixavg, get_mixture_specific_heat_cp_mass, get_mixture_enthalpy_mass + use m_thermochem, only: num_species, molecular_weights, get_temperature, get_net_production_rates, get_mole_fractions, & + & get_species_binary_mass_diffusivities, get_species_mass_diffusivities_mixavg, gas_constant, & + & get_mixture_molecular_weight, get_mixture_energy_mass, get_mixture_thermal_conductivity_mixavg, & + & get_species_enthalpies_rt, get_mixture_viscosity_mixavg, get_mixture_specific_heat_cp_mass, get_mixture_enthalpy_mass use m_global_parameters implicit none #:if USING_AMD - real(wp) :: molecular_weights_nonparameter(10) = & - (/2.016, 1.008, 15.999, 31.998, 17.007, 18.015, 33.006, & - 34.014, 39.95, 28.014/) + real(wp) :: molecular_weights_nonparameter(10) = (/2.016, 1.008, 15.999, 31.998, 17.007, 18.015, 33.006, 34.014, 39.95, & + & 28.014/) $:GPU_DECLARE(create='[molecular_weights_nonparameter]') #:endif @@ -31,46 +27,38 @@ module m_chemistry $:GPU_DECLARE(create='[isc1, isc2, isc3]') integer, dimension(3) :: offsets $:GPU_DECLARE(create='[offsets]') - contains !> @brief Computes mixture viscosities for left and right states and inverts them for use as reciprocal Reynolds numbers. subroutine compute_viscosity_and_inversion(T_L, Ys_L, T_R, Ys_R, Re_L, Re_R) + $:GPU_ROUTINE(function_name='compute_viscosity_and_inversion',parallelism='[seq]', cray_inline=True) - $:GPU_ROUTINE(function_name='compute_viscosity_and_inversion',parallelism='[seq]', & - & cray_inline=True) - - real(wp), intent(inout) :: T_L, T_R, Re_L, Re_R + real(wp), intent(inout) :: T_L, T_R, Re_L, Re_R real(wp), dimension(num_species), intent(inout) :: Ys_R, Ys_L call get_mixture_viscosity_mixavg(T_L, Ys_L, Re_L) call get_mixture_viscosity_mixavg(T_R, Ys_R, Re_R) Re_L = 1.0_wp/Re_L Re_R = 1.0_wp/Re_R - end subroutine compute_viscosity_and_inversion - !> @brief Initializes the temperature field from conservative variables by inverting the energy equation. subroutine s_compute_q_T_sf(q_T_sf, q_cons_vf, bounds) - ! Initialize the temperature field at the start of the simulation to ! reasonable values. Temperature is computed the regular way using the ! conservative variables. - type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - type(int_bounds_info), dimension(1:3), intent(in) :: bounds - - integer :: x, y, z, eqn - real(wp) :: energy, T_in - real(wp), dimension(num_species) :: Ys + type(int_bounds_info), dimension(1:3), intent(in) :: bounds + integer :: x, y, z, eqn + real(wp) :: energy, T_in + real(wp), dimension(num_species) :: Ys do z = bounds(3)%beg, bounds(3)%end do y = bounds(2)%beg, bounds(2)%end do x = bounds(1)%beg, bounds(1)%end do eqn = chemxb, chemxe - Ys(eqn - chemxb + 1) = & - q_cons_vf(eqn)%sf(x, y, z)/q_cons_vf(contxb)%sf(x, y, z) + Ys(eqn - chemxb + 1) = q_cons_vf(eqn)%sf(x, y, z)/q_cons_vf(contxb)%sf(x, y, z) end do ! e = E - 1/2*|u|^2 @@ -79,30 +67,24 @@ contains ! cons. momxb + i = \rho u_i energy = q_cons_vf(E_idx)%sf(x, y, z)/q_cons_vf(contxb)%sf(x, y, z) do eqn = momxb, momxe - energy = energy - & - 0.5_wp*(q_cons_vf(eqn)%sf(x, y, z)/q_cons_vf(contxb)%sf(x, y, z))**2._wp + energy = energy - 0.5_wp*(q_cons_vf(eqn)%sf(x, y, z)/q_cons_vf(contxb)%sf(x, y, z))**2._wp end do T_in = real(q_T_sf%sf(x, y, z), kind=wp) call get_temperature(energy, dflt_T_guess, Ys, .true., T_in) q_T_sf%sf(x, y, z) = T_in - end do end do end do - end subroutine s_compute_q_T_sf - !> @brief Computes the temperature field from primitive variables using the ideal gas law and mixture molecular weight. subroutine s_compute_T_from_primitives(q_T_sf, q_prim_vf, bounds) - - type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(int_bounds_info), dimension(1:3), intent(in) :: bounds - - integer :: x, y, z, i - real(wp), dimension(num_species) :: Ys - real(wp) :: mix_mol_weight + type(int_bounds_info), dimension(1:3), intent(in) :: bounds + integer :: x, y, z, i + real(wp), dimension(num_species) :: Ys + real(wp) :: mix_mol_weight do z = bounds(3)%beg, bounds(3)%end do y = bounds(2)%beg, bounds(2)%end @@ -116,21 +98,17 @@ contains end do end do end do - end subroutine s_compute_T_from_primitives - !> @brief Adds chemical reaction source terms to the species transport RHS using net production rates. subroutine s_compute_chemistry_reaction_flux(rhs_vf, q_cons_qp, q_T_sf, q_prim_qp, bounds) - type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_qp, q_prim_qp - type(int_bounds_info), dimension(1:3), intent(in) :: bounds - - integer :: x, y, z - integer :: eqn - real(wp) :: T - real(wp) :: rho, omega_m + type(int_bounds_info), dimension(1:3), intent(in) :: bounds + integer :: x, y, z + integer :: eqn + real(wp) :: T + real(wp) :: rho, omega_m #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(10) :: Ys real(wp), dimension(10) :: omega @@ -143,7 +121,6 @@ contains do z = bounds(3)%beg, bounds(3)%end do y = bounds(2)%beg, bounds(2)%end do x = bounds(1)%beg, bounds(1)%end - $:GPU_LOOP(parallelism='[seq]') do eqn = chemxb, chemxe Ys(eqn - chemxb + 1) = q_prim_qp(eqn)%sf(x, y, z) @@ -162,24 +139,18 @@ contains omega_m = molecular_weights(eqn - chemxb + 1)*omega(eqn - chemxb + 1) #:endif rhs_vf(eqn)%sf(x, y, z) = rhs_vf(eqn)%sf(x, y, z) + omega_m - end do - end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_compute_chemistry_reaction_flux - !> @brief Computes species mass diffusion fluxes at cell interfaces using mixture-averaged diffusivities. subroutine s_compute_chemistry_diffusion_flux(idir, q_prim_qp, flux_src_vf, irx, iry, irz) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_qp + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_qp type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - type(int_bounds_info), intent(in) :: irx, iry, irz - - integer, intent(in) :: idir + type(int_bounds_info), intent(in) :: irx, iry, irz + integer, intent(in) :: idir #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(10) :: Xs_L, Xs_R, Xs_cell, Ys_L, Ys_R, Ys_cell real(wp), dimension(10) :: mass_diffusivities_mixavg1, mass_diffusivities_mixavg2 @@ -192,29 +163,30 @@ contains real(wp), dimension(num_species) :: Mass_Diffu_Flux, dYk_dxi #:endif - real(wp) :: Mass_Diffu_Energy - real(wp) :: MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, T_L, T_R, P_L, P_R, rho_L, rho_R, rho_cell, rho_Vic - real(wp) :: lambda_L, lambda_R, lambda_Cell, dT_dxi, grid_spacing - real(wp) :: Cp_L, Cp_R - real(wp) :: diffusivity_L, diffusivity_R, diffusivity_cell - real(wp) :: hmix_L, hmix_R, dh_dxi - - integer :: x, y, z, i, n, eqn + real(wp) :: Mass_Diffu_Energy + real(wp) :: MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, T_L, T_R, P_L, P_R, rho_L, rho_R, rho_cell, rho_Vic + real(wp) :: lambda_L, lambda_R, lambda_Cell, dT_dxi, grid_spacing + real(wp) :: Cp_L, Cp_R + real(wp) :: diffusivity_L, diffusivity_R, diffusivity_cell + real(wp) :: hmix_L, hmix_R, dh_dxi + integer :: x, y, z, i, n, eqn integer, dimension(3) :: offsets isc1 = irx; isc2 = iry; isc3 = irz - $:GPU_UPDATE(device='[isc1,isc2,isc3]') + $:GPU_UPDATE(device='[isc1, isc2, isc3]') if (chemistry .or. dummy) then - ! Set offsets based on direction using array indexing offsets = 0 offsets(idir) = 1 ! Model 1: Mixture-Average Transport if (chem_params%transport_model == 1) then ! Note: Added 'i' and 'eqn' to private list. - $:GPU_PARALLEL_LOOP(collapse=3, private='[x,y,z,i,eqn,Ys_L, Ys_R, Ys_cell, Xs_L, Xs_R, mass_diffusivities_mixavg1, mass_diffusivities_mixavg2, mass_diffusivities_mixavg_Cell, h_l, h_r, Xs_cell, h_k, dXk_dxi,Mass_Diffu_Flux, Mass_Diffu_Energy, MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, T_L, T_R, P_L, P_R, rho_L, rho_R, rho_cell, rho_Vic, lambda_L, lambda_R, lambda_Cell, dT_dxi, grid_spacing]', copyin='[offsets]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[x, y, z, i, eqn, Ys_L, Ys_R, Ys_cell, Xs_L, Xs_R, & + & mass_diffusivities_mixavg1, mass_diffusivities_mixavg2, mass_diffusivities_mixavg_Cell, h_l, h_r, Xs_cell, h_k, & + & dXk_dxi, Mass_Diffu_Flux, Mass_Diffu_Energy, MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, T_L, T_R, P_L, P_R, & + & rho_L, rho_R, rho_cell, rho_Vic, lambda_L, lambda_R, lambda_Cell, dT_dxi, grid_spacing]', copyin='[offsets]') do z = isc3%beg, isc3%end do y = isc2%beg, isc2%end do x = isc1%beg, isc1%end @@ -274,8 +246,10 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe #:if USING_AMD - h_l(i - chemxb + 1) = h_l(i - chemxb + 1)*gas_constant*T_L/molecular_weights_nonparameter(i - chemxb + 1) - h_r(i - chemxb + 1) = h_r(i - chemxb + 1)*gas_constant*T_R/molecular_weights_nonparameter(i - chemxb + 1) + h_l(i - chemxb + 1) = h_l(i - chemxb + 1)*gas_constant*T_L/molecular_weights_nonparameter(i & + & - chemxb + 1) + h_r(i - chemxb + 1) = h_r(i - chemxb + 1)*gas_constant*T_R/molecular_weights_nonparameter(i & + & - chemxb + 1) #:else h_l(i - chemxb + 1) = h_l(i - chemxb + 1)*gas_constant*T_L/molecular_weights(i - chemxb + 1) h_r(i - chemxb + 1) = h_r(i - chemxb + 1)*gas_constant*T_R/molecular_weights(i - chemxb + 1) @@ -288,8 +262,8 @@ contains ! Calculate mixture-averaged diffusivities $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe - mass_diffusivities_mixavg_Cell(i - chemxb + 1) = & - (mass_diffusivities_mixavg2(i - chemxb + 1) + mass_diffusivities_mixavg1(i - chemxb + 1))/2.0_wp + mass_diffusivities_mixavg_Cell(i - chemxb + 1) = (mass_diffusivities_mixavg2(i - chemxb + 1) & + & + mass_diffusivities_mixavg1(i - chemxb + 1))/2.0_wp end do lambda_Cell = 0.5_wp*(lambda_R + lambda_L) @@ -301,11 +275,12 @@ contains $:GPU_LOOP(parallelism='[seq]') do eqn = chemxb, chemxe #:if USING_AMD - Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*mass_diffusivities_mixavg_Cell(eqn - chemxb + 1)* & - molecular_weights_nonparameter(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) + Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*mass_diffusivities_mixavg_Cell(eqn - chemxb + 1) & + & *molecular_weights_nonparameter(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn & + & - chemxb + 1) #:else - Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*mass_diffusivities_mixavg_Cell(eqn - chemxb + 1)* & - molecular_weights(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) + Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*mass_diffusivities_mixavg_Cell(eqn - chemxb + 1) & + & *molecular_weights(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) #:endif rho_Vic = rho_Vic + Mass_Diffu_Flux(eqn - chemxb + 1) Mass_Diffu_Energy = Mass_Diffu_Energy + h_k(eqn - chemxb + 1)*Mass_Diffu_Flux(eqn - chemxb + 1) @@ -315,7 +290,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do eqn = chemxb, chemxe Mass_Diffu_Energy = Mass_Diffu_Energy - h_k(eqn - chemxb + 1)*Ys_cell(eqn - chemxb + 1)*rho_Vic - Mass_Diffu_Flux(eqn - chemxb + 1) = Mass_Diffu_Flux(eqn - chemxb + 1) - rho_Vic*Ys_cell(eqn - chemxb + 1) + Mass_Diffu_Flux(eqn - chemxb + 1) = Mass_Diffu_Flux(eqn - chemxb + 1) - rho_Vic*Ys_cell(eqn & + & - chemxb + 1) end do ! Add thermal conduction contribution @@ -336,7 +312,10 @@ contains ! Model 2: Unity Lewis Number else if (chem_params%transport_model == 2) then ! Note: Added ALL scalars and 'i'/'eqn' to private list to prevent race conditions. - $:GPU_PARALLEL_LOOP(collapse=3, private='[x,y,z,i,eqn,Ys_L, Ys_R, Ys_cell, dYk_dxi, Mass_Diffu_Flux, grid_spacing, MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, P_L, P_R, rho_L, rho_R, rho_cell, T_L, T_R, Cp_L, Cp_R, hmix_L, hmix_R, dh_dxi, lambda_L, lambda_R, lambda_Cell, diffusivity_L, diffusivity_R, diffusivity_cell, Mass_Diffu_Energy]', copyin='[offsets]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[x, y, z, i, eqn, Ys_L, Ys_R, Ys_cell, dYk_dxi, Mass_Diffu_Flux, & + & grid_spacing, MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, P_L, P_R, rho_L, rho_R, rho_cell, T_L, T_R, Cp_L, Cp_R, & + & hmix_L, hmix_R, dh_dxi, lambda_L, lambda_R, lambda_Cell, diffusivity_L, diffusivity_R, diffusivity_cell, & + & Mass_Diffu_Energy]', copyin='[offsets]') do z = isc3%beg, isc3%end do y = isc2%beg, isc2%end do x = isc1%beg, isc1%end @@ -391,8 +370,7 @@ contains ! Calculate species properties and gradients $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe - dYk_dxi(i - chemxb + 1) = (Ys_R(i - chemxb + 1) - & - Ys_L(i - chemxb + 1))/grid_spacing + dYk_dxi(i - chemxb + 1) = (Ys_R(i - chemxb + 1) - Ys_L(i - chemxb + 1))/grid_spacing end do ! Calculate mixture-averaged diffusivities @@ -407,9 +385,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do eqn = chemxb, chemxe - Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell* & - diffusivity_cell* & - dYk_dxi(eqn - chemxb + 1) + Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*diffusivity_cell*dYk_dxi(eqn - chemxb + 1) end do Mass_Diffu_Energy = rho_cell*diffusivity_cell*dh_dxi @@ -426,7 +402,5 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if - end subroutine s_compute_chemistry_diffusion_flux - end module m_chemistry diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index 6820ef3a9a..4c3d65a2fe 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -4,95 +4,81 @@ !> @brief Platform-specific file and directory operations: create, delete, inquire, getcwd, and basename module m_compile_specific - ! Dependencies use m_mpi_proxy implicit none - contains - !> Creates a directory and all its parents if it does not exist - !! @param dir_name Directory path + !> Creates a directory and all its parents if it does not exist + !! @param dir_name Directory path impure subroutine s_create_directory(dir_name) character(LEN=*), intent(in) :: dir_name #ifdef _WIN32 - call system('mkdir "'//dir_name//'" 2> NUL') + call system('mkdir "' // dir_name // '" 2> NUL') #else - call system('mkdir -p "'//dir_name//'"') + call system('mkdir -p "' // dir_name // '"') #endif - end subroutine s_create_directory - !> @brief Deletes a file at the given path using a platform-specific system command. impure subroutine s_delete_file(filepath) character(LEN=*), intent(in) :: filepath #ifdef _WIN32 - call system('del "'//filepath//'"') + call system('del "' // filepath // '"') #else - call system('rm "'//filepath//'"') + call system('rm "' // filepath // '"') #endif - end subroutine s_delete_file - !> @brief Recursively deletes a directory using a platform-specific system command. impure subroutine s_delete_directory(dir_name) character(LEN=*), intent(in) :: dir_name #ifdef _WIN32 - call system('rmdir "'//dir_name//'" /s /q') + call system('rmdir "' // dir_name // '" /s /q') #else - call system('rm -r "'//dir_name//'"') + call system('rm -r "' // dir_name // '"') #endif - end subroutine s_delete_directory - - !> Inquires on the existence of a directory - !! @param fileloc File directory location - !! @param dircheck Switch that indicates if directory exists + !> Inquires on the existence of a directory + !! @param fileloc File directory location + !! @param dircheck Switch that indicates if directory exists impure subroutine my_inquire(fileloc, dircheck) character(LEN=*), intent(in) :: fileloc - logical, intent(inout) :: dircheck + logical, intent(inout) :: dircheck #ifdef __INTEL_COMPILER - inquire (DIRECTORY=trim(fileloc), EXIST=dircheck) !Intel + inquire (DIRECTORY=trim(fileloc), EXIST=dircheck) ! Intel #else - inquire (FILE=trim(fileloc), EXIST=dircheck) !GCC + inquire (FILE=trim(fileloc), EXIST=dircheck) ! GCC #endif - end subroutine my_inquire - !> @brief Retrieves the current working directory path via the GETCWD intrinsic. impure subroutine s_get_cwd(cwd) character(LEN=*), intent(out) :: cwd call GETCWD(cwd) end subroutine s_get_cwd - !> @brief Extracts the base filename from a directory path using the system basename command. impure subroutine s_get_basename(dirpath, basename) - character(LEN=*), intent(in) :: dirpath + character(LEN=*), intent(in) :: dirpath character(LEN=*), intent(out) :: basename - - integer :: iUnit - character(len=30) :: tmpfilepath + integer :: iUnit + character(len=30) :: tmpfilepath write (tmpfilepath, '(A,I0)') 'basename_', proc_rank #ifdef _WIN32 - call system('for /F %i in ("'//trim(dirpath)//'") do @echo %~ni > '//trim(tmpfilepath)) + call system('for /F %i in ("' // trim(dirpath) // '") do @echo %~ni > ' // trim(tmpfilepath)) #else - call system('basename "'//trim(dirpath)//'" > '//trim(tmpfilepath)) + call system('basename "' // trim(dirpath) // '" > ' // trim(tmpfilepath)) #endif - open (newunit=iUnit, FILE=trim(tmpfilepath), FORM='formatted', STATUS='old') + open (newunit=iUnit, FILE=trim(tmpfilepath), form='formatted', STATUS='old') read (iUnit, '(A)') basename close (iUnit) call s_delete_file(trim(tmpfilepath)) - end subroutine s_get_basename - end module m_compile_specific diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index ece614b089..f5153347c6 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -4,41 +4,44 @@ !> @brief Compile-time constant parameters: default values, tolerances, and physical constants module m_constants - use m_precision_select character, parameter :: dflt_char = ' ' !< Default string value - - real(wp), parameter :: dflt_real = -1.e6_wp !< Default real value - real(wp), parameter :: sgm_eps = 1.e-16_wp !< Segmentation tolerance - real(wp), parameter :: Chem_Tolerance = 1.e-16_wp !< Speed of Sound Tolerance in Chemistry - real(wp), parameter :: small_alf = 1.e-11_wp !< Small alf tolerance - real(wp), parameter :: pi = 3.141592653589793_wp !< Pi - real(wp), parameter :: verysmall = 1.e-12_wp !< Very small number - real(wp), parameter :: small_radius = 1.e-32_wp !< Radius cutoff to avoid division by zero for 3D spherical harmonic patch (geometry 14) - - integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils - integer, parameter :: path_len = 400 !< Maximum path length - integer, parameter :: name_len = 50 !< Maximum name length - integer, parameter :: dflt_int = -100 !< Default integer value - integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit - integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation - integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation - integer, parameter :: num_patches_max = 1000 - integer, parameter :: num_bc_patches_max = 10 - integer, parameter :: max_2d_fourier_modes = 10 !< Max Fourier mode index for 2D modal patch (geometry 13) - integer, parameter :: max_sph_harm_degree = 5 !< Max degree L for 3D spherical harmonic patch (geometry 14) - integer, parameter :: pathlen_max = 400 - integer, parameter :: nnode = 4 !< Number of QBMM nodes - integer, parameter :: dflt_num_igr_iters = 2 !< number of iterations for IGR elliptic solve - integer, parameter :: dflt_num_igr_warm_start_iters = 50 !< default number of iterations for IGR elliptic solve + real(wp), parameter :: dflt_real = -1.e6_wp !< Default real value + real(wp), parameter :: sgm_eps = 1.e-16_wp !< Segmentation tolerance + real(wp), parameter :: Chem_Tolerance = 1.e-16_wp !< Speed of Sound Tolerance in Chemistry + real(wp), parameter :: small_alf = 1.e-11_wp !< Small alf tolerance + real(wp), parameter :: pi = 3.141592653589793_wp !< Pi + real(wp), parameter :: verysmall = 1.e-12_wp !< Very small number + real(wp), & + & parameter :: small_radius = 1.e-32_wp !< Radius cutoff to avoid division by zero for 3D spherical harmonic patch (geometry 14) + + integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils + integer, parameter :: path_len = 400 !< Maximum path length + integer, parameter :: name_len = 50 !< Maximum name length + integer, parameter :: dflt_int = -100 !< Default integer value + integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit + integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation + integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation + integer, parameter :: num_patches_max = 1000 + integer, parameter :: num_bc_patches_max = 10 + integer, parameter :: max_2d_fourier_modes = 10 !< Max Fourier mode index for 2D modal patch (geometry 13) + integer, parameter :: max_sph_harm_degree = 5 !< Max degree L for 3D spherical harmonic patch (geometry 14) + integer, parameter :: pathlen_max = 400 + integer, parameter :: nnode = 4 !< Number of QBMM nodes + integer, parameter :: dflt_num_igr_iters = 2 !< number of iterations for IGR elliptic solve + integer, parameter :: dflt_num_igr_warm_start_iters = 50 !< default number of iterations for IGR elliptic solve real(wp), parameter :: dflt_alf_factor = 10._wp !< scaling factor for IGR alpha - integer, parameter :: gp_layers = 3 !< Number of ghost point layers for IBM - real(wp), parameter :: capillary_cutoff = 1.e-6 !< color function gradient magnitude at which to apply the surface tension fluxes - real(wp), parameter :: acoustic_spatial_support_width = 2.5_wp !< Spatial support width of acoustic source, used in s_source_spatial + integer, parameter :: gp_layers = 3 !< Number of ghost point layers for IBM + real(wp), & + & parameter :: capillary_cutoff = 1.e-6 !< color function gradient magnitude at which to apply the surface tension fluxes + real(wp), & + & parameter :: acoustic_spatial_support_width = 2.5_wp !< Spatial support width of acoustic source, used in s_source_spatial real(wp), parameter :: dflt_vcfl_dt = 100._wp !< value of vcfl_dt when viscosity is off for computing adaptive timestep size - real(wp), parameter :: broadband_spectral_level_constant = 20._wp !< The constant to scale the spectral level at the lower frequency bound - real(wp), parameter :: broadband_spectral_level_growth_rate = 10._wp !< The spectral level constant to correct the magnitude at each frequency to ensure the source is overall broadband + real(wp), & + & parameter :: broadband_spectral_level_constant = 20._wp !< The constant to scale the spectral level at the lower frequency bound + real(wp), & + & parameter :: broadband_spectral_level_growth_rate = 10._wp !< The spectral level constant to correct the magnitude at each frequency to ensure the source is overall broadband ! Reconstruction Types integer, parameter :: WENO_TYPE = 1 !< Using WENO for reconstruction type @@ -53,22 +56,23 @@ module m_constants real(wp), parameter :: dflt_T_guess = 1200._wp ! Default guess for temperature (when a previous value is not available) ! IBM+STL interpolation constants - integer, parameter :: num_ray = 20 !< Default number of rays traced per cell + integer, parameter :: num_ray = 20 !< Default number of rays traced per cell real(wp), parameter :: ray_tracing_threshold = 0.9_wp !< Threshold above which the cell is marked as the model patch real(wp), parameter :: threshold_vector_zero = 1.e-10_wp !< Threshold to treat the component of a vector to be zero real(wp), parameter :: threshold_edge_zero = 1.e-10_wp !< Threshold to treat two edges to be overlapped real(wp), parameter :: initial_distance_buffer = 1.e12_wp !< Initialized levelset distance for the shortest path pair algorithm ! Lagrange bubbles constants - integer, parameter :: mapCells = 3 !< Number of cells around the bubble where the smoothening function will have effect + integer, parameter :: mapCells = 3 !< Number of cells around the bubble where the smoothening function will have effect real(wp), parameter :: R_uni = 8314._wp !< Universal gas constant - J/kmol/K - integer, parameter :: lag_io_vars = 21 ! Number of variables per particle for MPI_IO + integer, parameter :: lag_io_vars = 21 ! Number of variables per particle for MPI_IO ! Strang Splitting constants real(wp), parameter :: dflt_adap_dt_tol = 1.e-4_wp !< Default tolerance for adaptive step size - integer, parameter :: dflt_adap_dt_max_iters = 100 !< Default max iteration for adaptive step size + integer, parameter :: dflt_adap_dt_max_iters = 100 !< Default max iteration for adaptive step size - ! Constants of the algorithm described by Heirer, E. Hairer, S. P.Nørsett, G. Wanner, Solving Ordinary Differential Equations I, Chapter II.4 + ! Constants of the algorithm described by Heirer, E. Hairer, S. P.Norsett, G. Wanner, Solving Ordinary Differential Equations I, + ! Chapter II.4 ! to choose the initial time step size for the adaptive time stepping routine real(wp), parameter :: threshold_first_guess = 1.e-5_wp real(wp), parameter :: threshold_second_guess = 1.e-15_wp @@ -80,10 +84,10 @@ module m_constants integer, parameter :: relativity_cons_to_prim_max_iter = 100 ! Pseudo-random number generator - integer, parameter :: modulus = 2**30 - 1 - integer, parameter :: multiplier = 1664525 - integer, parameter :: increment = 1013904223 - integer, parameter :: amplifier = 3**13 + integer, parameter :: modulus = 2**30 - 1 + integer, parameter :: multiplier = 1664525 + integer, parameter :: increment = 1013904223 + integer, parameter :: amplifier = 3**13 real(wp), parameter :: decimal_trim = 1.e5_wp ! System constants @@ -114,5 +118,4 @@ module m_constants integer, parameter :: BC_SLIP_WALL = -15 integer, parameter :: BC_NO_SLIP_WALL = -16 integer, parameter :: BC_DIRICHLET = -17 - end module m_constants diff --git a/src/common/m_delay_file_access.f90 b/src/common/m_delay_file_access.f90 index 096bbbb6af..f567ccb1a7 100644 --- a/src/common/m_delay_file_access.f90 +++ b/src/common/m_delay_file_access.f90 @@ -10,28 +10,21 @@ module m_delay_file_access public :: DelayFileAccess - integer, private, parameter :: & - N_PROCESSES_FILE_ACCESS = 128, & - FILE_ACCESS_DELAY_UNIT = 10000 - + integer, private, parameter :: N_PROCESSES_FILE_ACCESS = 128, FILE_ACCESS_DELAY_UNIT = 10000 contains !> @brief Introduces a rank-dependent busy-wait delay to stagger parallel file access and reduce I/O contention. impure subroutine DelayFileAccess(ProcessRank) integer, intent(in) :: ProcessRank + integer :: iDelay, nFileAccessDelayIterations + real(wp) :: Number, Dummy - integer :: iDelay, nFileAccessDelayIterations - real(wp) :: Number, Dummy - - nFileAccessDelayIterations & - = (ProcessRank/N_PROCESSES_FILE_ACCESS)*FILE_ACCESS_DELAY_UNIT + nFileAccessDelayIterations = (ProcessRank/N_PROCESSES_FILE_ACCESS)*FILE_ACCESS_DELAY_UNIT do iDelay = 1, nFileAccessDelayIterations ! Wait my turn call random_number(Number) Dummy = Number*Number end do - end subroutine DelayFileAccess - end module m_delay_file_access diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 36655366ab..43a33202c0 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -6,7 +6,6 @@ !> @brief Shared derived types for field data, patch geometry, bubble dynamics, and MPI I/O structures module m_derived_types - use m_constants !< Constants use m_precision_select @@ -16,55 +15,55 @@ module m_derived_types !> Derived type adding the field position (fp) as an attribute type field_position - real(stp), allocatable, dimension(:, :, :) :: fp !< Field position + real(stp), allocatable, dimension(:,:,:) :: fp !< Field position end type field_position !> Derived type annexing a scalar field (SF) type scalar_field - real(stp), pointer, dimension(:, :, :) :: sf => null() + real(stp), pointer, dimension(:,:,:) :: sf => null() end type scalar_field !> Derived type for bubble variables pb and mv at quadrature nodes (qbmm) type pres_field - real(stp), pointer, dimension(:, :, :, :, :) :: sf => null() + real(stp), pointer, dimension(:,:,:,:,:) :: sf => null() end type pres_field !> Derived type annexing an integer scalar field (SF) type integer_field #ifdef MFC_MIXED_PRECISION - integer(kind=1), pointer, dimension(:, :, :) :: sf => null() + integer(kind=1), pointer, dimension(:,:,:) :: sf => null() #else - integer, pointer, dimension(:, :, :) :: sf => null() + integer, pointer, dimension(:,:,:) :: sf => null() #endif end type integer_field !> Derived type for levelset type levelset_field - real(stp), pointer, dimension(:, :, :, :) :: sf => null() + real(stp), pointer, dimension(:,:,:,:) :: sf => null() end type levelset_field !> Derived type for levelset norm type levelset_norm_field - real(stp), pointer, dimension(:, :, :, :, :) :: sf => null() + real(stp), pointer, dimension(:,:,:,:,:) :: sf => null() end type levelset_norm_field type mpi_io_var - integer, allocatable, dimension(:) :: view + integer, allocatable, dimension(:) :: view type(scalar_field), allocatable, dimension(:) :: var end type mpi_io_var type mpi_io_ib_var - integer :: view + integer :: view type(integer_field) :: var end type mpi_io_ib_var type mpi_io_levelset_var - integer :: view + integer :: view type(levelset_field) :: var end type mpi_io_levelset_var type mpi_io_levelset_norm_var - integer :: view + integer :: view type(levelset_norm_field) :: var end type mpi_io_levelset_norm_var @@ -73,8 +72,8 @@ module m_derived_types type(scalar_field), allocatable, dimension(:) :: vf !< Vector field end type vector_field - !> Generic 3-component vector (e.g., spatial coordinates or field components) - !! Named _dt (derived types: x,y,z) to differentiate from t_vec3 (3-component vector) + !> Generic 3-component vector (e.g., spatial coordinates or field components) Named _dt (derived types: x,y,z) to differentiate + !! from t_vec3 (3-component vector) type vec3_dt ! dt for derived types real(wp) :: x real(wp) :: y @@ -95,30 +94,28 @@ module m_derived_types !> Integer bounds for variables type int_bounds_info - integer :: beg - integer :: end - - real(wp) :: vb1 - real(wp) :: vb2 - real(wp) :: vb3 - real(wp) :: ve1 - real(wp) :: ve2 - real(wp) :: ve3 - real(wp) :: pres_in, pres_out - real(wp), dimension(3) :: vel_in, vel_out + integer :: beg + integer :: end + real(wp) :: vb1 + real(wp) :: vb2 + real(wp) :: vb3 + real(wp) :: ve1 + real(wp) :: ve2 + real(wp) :: ve3 + real(wp) :: pres_in, pres_out + real(wp), dimension(3) :: vel_in, vel_out real(wp), dimension(num_fluids_max) :: alpha_rho_in, alpha_in - logical :: grcbc_in, grcbc_out, grcbc_vel_out - + logical :: grcbc_in, grcbc_out, grcbc_vel_out end type int_bounds_info type bc_patch_parameters - integer :: geometry - integer :: type - integer :: dir - integer :: loc + integer :: geometry + integer :: type + integer :: dir + integer :: loc real(wp), dimension(3) :: centroid real(wp), dimension(3) :: length - real(wp) :: radius + real(wp) :: radius end type bc_patch_parameters !> Derived type adding beginning (beg) and end bounds info as attributes @@ -129,14 +126,14 @@ module m_derived_types !> bounds for the bubble dynamic variables type bub_bounds_info - integer :: beg - integer :: end - integer, dimension(:), allocatable :: rs - integer, dimension(:), allocatable :: vs - integer, dimension(:), allocatable :: ps - integer, dimension(:), allocatable :: ms - integer, dimension(:, :), allocatable :: moms !< Moment indices for qbmm - integer, dimension(:, :, :), allocatable :: fullmom !< Moment indices for qbmm + integer :: beg + integer :: end + integer, dimension(:), allocatable :: rs + integer, dimension(:), allocatable :: vs + integer, dimension(:), allocatable :: ps + integer, dimension(:), allocatable :: ms + integer, dimension(:,:), allocatable :: moms !< Moment indices for qbmm + integer, dimension(:,:,:), allocatable :: fullmom !< Moment indices for qbmm end type bub_bounds_info !> Defines parameters for a Model Patch @@ -163,7 +160,7 @@ module m_derived_types type :: t_triangle real(wp), dimension(1:3, 1:3) :: v ! Vertices of the triangle - real(wp), dimension(1:3) :: n ! Normal vector + real(wp), dimension(1:3) :: n ! Normal vector end type t_triangle type :: t_ray @@ -177,41 +174,37 @@ module m_derived_types end type t_bbox type :: t_model - integer :: ntrs ! Number of triangles + integer :: ntrs ! Number of triangles type(t_triangle), allocatable :: trs(:) ! Triangles - end type t_model type :: t_model_array ! Original CPU-side fields (unchanged) - type(t_model), allocatable :: model - real(wp), allocatable, dimension(:, :, :) :: boundary_v - real(wp), allocatable, dimension(:, :) :: interpolated_boundary_v - integer :: boundary_edge_count - integer :: total_vertices - integer :: interpolate + type(t_model), allocatable :: model + real(wp), allocatable, dimension(:,:,:) :: boundary_v + real(wp), allocatable, dimension(:,:) :: interpolated_boundary_v + integer :: boundary_edge_count + integer :: total_vertices + integer :: interpolate ! GPU-friendly flattened arrays - integer :: ntrs ! copy of model%ntrs - real(wp), allocatable, dimension(:, :, :) :: trs_v ! (3, 3, ntrs) - triangle vertices - real(wp), allocatable, dimension(:, :) :: trs_n ! (3, ntrs) - triangle normals + integer :: ntrs ! copy of model%ntrs + real(wp), allocatable, dimension(:,:,:) :: trs_v ! (3, 3, ntrs) - triangle vertices + real(wp), allocatable, dimension(:,:) :: trs_n ! (3, ntrs) - triangle normals end type t_model_array - !> Derived type adding initial condition (ic) patch parameters as attributes - !! NOTE: The requirements for the specification of the above parameters - !! are strongly dependent on both the choice of the multicomponent flow - !! model as well as the choice of the patch geometry. + !> Derived type adding initial condition (ic) patch parameters as attributes NOTE: The requirements for the specification of the + !! above parameters are strongly dependent on both the choice of the multicomponent flow model as well as the choice of the + !! patch geometry. type ic_patch_parameters - integer :: geometry !< Type of geometry for the patch - + integer :: geometry !< Type of geometry for the patch real(wp) :: x_centroid, y_centroid, z_centroid !< !! Location of the geometric center, i.e. the centroid, of the patch. It !! is specified through its x-, y- and z-coordinates, respectively. - real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. - + real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. + real(wp) :: radius !< Dimensions of the patch. radius. real(wp), dimension(3) :: radii !< !! Vector indicating the various radii for the elliptical and ellipsoidal !! patch geometries. It is specified through its x-, y-, and z-components @@ -228,14 +221,13 @@ module m_derived_types ! Geometry 13 (2D modal Fourier): fourier_cos(n), fourier_sin(n) for mode n real(wp), dimension(1:max_2d_fourier_modes) :: fourier_cos, fourier_sin - logical :: modal_clip_r_to_min !< When true, clip boundary radius: R(theta) = max(R(theta), modal_r_min) (Non-exp form only) - real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) - logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) + logical :: modal_clip_r_to_min !< When true, clip boundary radius: R(theta) = max(R(theta), modal_r_min) (Non-exp form only) + real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) + logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) ! Geometry 14 (3D spherical harmonic): sph_har_coeff(l,m) for real Y_lm real(wp), dimension(0:max_sph_harm_degree, -max_sph_harm_degree:max_sph_harm_degree) :: sph_har_coeff - - real(wp), dimension(3) :: normal !< + real(wp), dimension(3) :: normal !< !! Normal vector indicating the orientation of the patch. It is specified !! through its x-, y- and z-components, respectively. @@ -257,20 +249,19 @@ module m_derived_types !! cells across which boundaries of the current patch will be smeared out real(wp), dimension(num_fluids_max) :: alpha_rho - real(wp) :: rho - real(wp), dimension(3) :: vel - real(wp) :: pres + real(wp) :: rho + real(wp), dimension(3) :: vel + real(wp) :: pres real(wp), dimension(num_fluids_max) :: alpha - real(wp) :: gamma - real(wp) :: pi_inf !< - real(wp) :: cv !< - real(wp) :: qv !< - real(wp) :: qvp !< + real(wp) :: gamma + real(wp) :: pi_inf !< + real(wp) :: cv !< + real(wp) :: qv !< + real(wp) :: qvp !< !! Primitive variables associated with the patch. In order, these include !! the partial densities, density, velocity, pressure, volume fractions, !! specific heat ratio function and the liquid stiffness function. - real(wp) :: Bx, By, Bz !< !! Magnetic field components; B%x is not used for 1D @@ -279,11 +270,9 @@ module m_derived_types real(wp) :: R0 !< Bubble size real(wp) :: V0 !< Bubble velocity - real(wp) :: p0 !< Bubble size real(wp) :: m0 !< Bubble velocity - - integer :: hcid + integer :: hcid !! id for hard coded initial condition real(wp) :: cf_val !! color function value @@ -308,32 +297,28 @@ module m_derived_types real(wp) :: model_threshold !< !! Threshold to turn on smoothen STL patch. - end type ic_patch_parameters type ib_patch_parameters - integer :: geometry !< Type of geometry for the patch - + integer :: geometry !< Type of geometry for the patch real(wp) :: x_centroid, y_centroid, z_centroid !< !! Location of the geometric center, i.e. the centroid, of the patch. It !! is specified through its x-, y- and z-coordinates, respectively. real(wp) :: step_x_centroid, step_y_centroid, step_z_centroid !< !! Centroid locations of intermediate steps in the time_stepper module - real(wp), dimension(1:3) :: centroid_offset ! offset of center of mass from computed cell center for odd-shaped IBs - - real(wp), dimension(1:3) :: angles - real(wp), dimension(1:3) :: step_angles + real(wp), dimension(1:3) :: centroid_offset ! offset of center of mass from computed cell center for odd-shaped IBs + real(wp), dimension(1:3) :: angles + real(wp), dimension(1:3) :: step_angles real(wp), dimension(1:3, 1:3) :: rotation_matrix !< matrix that converts from IB reference frame to fluid reference frame - real(wp), dimension(1:3, 1:3) :: rotation_matrix_inverse !< matrix that converts from fluid reference frame to IB reference frame + real(wp), dimension(1:3, & + & 1:3) :: rotation_matrix_inverse !< matrix that converts from fluid reference frame to IB reference frame real(wp) :: c, p, t, m - real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. real(wp) :: radius !< Dimensions of the patch. radius. real(wp) :: theta - - logical :: slip + logical :: slip !! STL or OBJ model input parameter character(LEN=pathlen_max) :: model_filepath !< @@ -356,26 +341,25 @@ module m_derived_types !! Threshold to turn on smoothen STL patch. !! Patch conditions for moving imersed boundaries - integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path - real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling + integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path + real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling real(wp), dimension(1:3) :: force, torque ! vectors for the computed force and torque values applied to an IB real(wp), dimension(1:3) :: vel real(wp), dimension(1:3) :: step_vel ! velocity array used to store intermediate steps in the time_stepper module real(wp), dimension(1:3) :: angular_vel real(wp), dimension(1:3) :: step_angular_vel ! velocity array used to store intermediate steps in the time_stepper module - end type ib_patch_parameters - !> Derived type annexing the physical parameters (PP) of the fluids. These - !! include the specific heat ratio function and liquid stiffness function. + !> Derived type annexing the physical parameters (PP) of the fluids. These include the specific heat ratio function and liquid + !! stiffness function. type physical_parameters - real(wp) :: gamma !< Sp. heat ratio - real(wp) :: pi_inf !< Liquid stiffness + real(wp) :: gamma !< Sp. heat ratio + real(wp) :: pi_inf !< Liquid stiffness real(wp), dimension(2) :: Re !< Reynolds number - real(wp) :: cv !< heat capacity - real(wp) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) - real(wp) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) - real(wp) :: G + real(wp) :: cv !< heat capacity + real(wp) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) + real(wp) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) + real(wp) :: G end type physical_parameters !> Derived type annexing the physical parameters required for sub-grid bubble models @@ -403,7 +387,7 @@ module m_derived_types end type subgrid_bubble_physical_parameters type mpi_io_airfoil_ib_var - integer, dimension(2) :: view + integer, dimension(2) :: view type(vec3_dt), allocatable, dimension(:) :: var end type mpi_io_airfoil_ib_var @@ -419,53 +403,53 @@ module m_derived_types !> Acoustic source parameters type acoustic_parameters - integer :: pulse !< Type of pulse - integer :: support !< Type of support - logical :: dipole !< Whether the source is a dipole or monopole + integer :: pulse !< Type of pulse + integer :: support !< Type of support + logical :: dipole !< Whether the source is a dipole or monopole real(wp), dimension(3) :: loc !< Physical location of acoustic source - real(wp) :: mag !< Acoustic pulse magnitude - real(wp) :: length !< Length of planar source (2D/3D) - real(wp) :: height !< Height of planar source (3D) - real(wp) :: wavelength !< Wave length of pulse - real(wp) :: frequency !< Frequency of pulse - real(wp) :: gauss_sigma_dist !< sigma of Gaussian pulse multiplied by speed of sound - real(wp) :: gauss_sigma_time !< sigma of Gaussian pulse - real(wp) :: npulse !< Number of cycles of pulse - real(wp) :: dir !< Direction of pulse - real(wp) :: delay !< Time-delay of pulse start - real(wp) :: foc_length ! < Focal length of transducer - real(wp) :: aperture ! < Aperture diameter of transducer - real(wp) :: element_spacing_angle !< Spacing between aperture elements in 2D acoustic array - real(wp) :: element_polygon_ratio !< Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array + real(wp) :: mag !< Acoustic pulse magnitude + real(wp) :: length !< Length of planar source (2D/3D) + real(wp) :: height !< Height of planar source (3D) + real(wp) :: wavelength !< Wave length of pulse + real(wp) :: frequency !< Frequency of pulse + real(wp) :: gauss_sigma_dist !< sigma of Gaussian pulse multiplied by speed of sound + real(wp) :: gauss_sigma_time !< sigma of Gaussian pulse + real(wp) :: npulse !< Number of cycles of pulse + real(wp) :: dir !< Direction of pulse + real(wp) :: delay !< Time-delay of pulse start + real(wp) :: foc_length ! < Focal length of transducer + real(wp) :: aperture ! < Aperture diameter of transducer + real(wp) :: element_spacing_angle !< Spacing between aperture elements in 2D acoustic array + real(wp) & + & :: element_polygon_ratio !< Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array real(wp) :: rotate_angle !< Angle of rotation of the entire circular 3D acoustic array real(wp) :: bb_bandwidth !< Bandwidth of each frequency in broadband wave real(wp) :: bb_lowest_freq !< The lower frequency bound of broadband wave - integer :: num_elements !< Number of elements in the acoustic array - integer :: element_on !< Element in the acoustic array to turn on - integer :: bb_num_freq !< Number of frequencies in the broadband wave + integer :: num_elements !< Number of elements in the acoustic array + integer :: element_on !< Element in the acoustic array to turn on + integer :: bb_num_freq !< Number of frequencies in the broadband wave end type acoustic_parameters !> Acoustic source source_spatial pre-calculated values type source_spatial_type - integer, pointer, dimension(:, :) :: coord => null() !< List of grid points indices with non-zero source_spatial values - real(wp), pointer, dimension(:) :: val => null() !< List of non-zero source_spatial values - real(wp), pointer, dimension(:) :: angle => null() !< List of angles with x-axis for mom source term vector - real(wp), pointer, dimension(:, :) :: xyz_to_r_ratios => null() !< List of [xyz]/r for mom source term vector - + integer, pointer, dimension(:,:) :: coord => null() !< List of grid points indices with non-zero source_spatial values + real(wp), pointer, dimension(:) :: val => null() !< List of non-zero source_spatial values + real(wp), pointer, dimension(:) :: angle => null() !< List of angles with x-axis for mom source term vector + real(wp), pointer, dimension(:,:) :: xyz_to_r_ratios => null() !< List of [xyz]/r for mom source term vector end type source_spatial_type !> Ghost Point for Immersed Boundaries type ghost_point - integer, dimension(3) :: loc !< Physical location of the ghost point - real(wp), dimension(3) :: ip_loc !< Physical location of the image point - integer, dimension(3) :: ip_grid !< Top left grid point of IP + integer, dimension(3) :: loc !< Physical location of the ghost point + real(wp), dimension(3) :: ip_loc !< Physical location of the image point + integer, dimension(3) :: ip_grid !< Top left grid point of IP real(wp), dimension(2, 2, 2) :: interp_coeffs !< Interpolation Coefficients of image point - integer :: ib_patch_id !< ID of the IB Patch the ghost point is part of - real(wp) :: levelset - real(wp), dimension(1:3) :: levelset_norm - logical :: slip - integer, dimension(3) :: DB - integer :: x_periodicity, y_periodicity, z_periodicity + integer :: ib_patch_id !< ID of the IB Patch the ghost point is part of + real(wp) :: levelset + real(wp), dimension(1:3) :: levelset_norm + logical :: slip + integer, dimension(3) :: DB + integer :: x_periodicity, y_periodicity, z_periodicity end type ghost_point !> Species parameters @@ -476,9 +460,8 @@ module m_derived_types !> Chemistry parameters type chemistry_parameters character(LEN=name_len) :: cantera_file !< Path to Cantera file - - logical :: diffusion - logical :: reactions + logical :: diffusion + logical :: reactions !> Method of determining gamma. !> gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. @@ -490,19 +473,18 @@ module m_derived_types !> Lagrangian bubble parameters type bubbles_lagrange_parameters - integer :: solver_approach !< 1: One-way coupling, 2: two-way coupling - integer :: cluster_type !< Cluster model to find p_inf - logical :: pressure_corrector !< Cell pressure correction term - integer :: smooth_type !< Smoothing function. 1: Gaussian, 2:Delta 3x3 - logical :: heatTransfer_model !< Activate HEAT transfer model at the bubble-liquid interface - logical :: massTransfer_model !< Activate MASS transfer model at the bubble-liquid interface - logical :: write_bubbles !< Write files to track the bubble evolution each time step - logical :: write_bubbles_stats !< Write the maximum and minimum radius of each bubble - integer :: nBubs_glb !< Global number of bubbles + integer :: solver_approach !< 1: One-way coupling, 2: two-way coupling + integer :: cluster_type !< Cluster model to find p_inf + logical :: pressure_corrector !< Cell pressure correction term + integer :: smooth_type !< Smoothing function. 1: Gaussian, 2:Delta 3x3 + logical :: heatTransfer_model !< Activate HEAT transfer model at the bubble-liquid interface + logical :: massTransfer_model !< Activate MASS transfer model at the bubble-liquid interface + logical :: write_bubbles !< Write files to track the bubble evolution each time step + logical :: write_bubbles_stats !< Write the maximum and minimum radius of each bubble + integer :: nBubs_glb !< Global number of bubbles real(wp) :: epsilonb !< Standard deviation scaling for the gaussian function real(wp) :: charwidth !< Domain virtual depth (z direction, for 2D simulations) real(wp) :: valmaxvoid !< Maximum void fraction permitted - end type bubbles_lagrange_parameters !> Max and min number of cells in a direction of each combination of x-,y-, and z- @@ -512,16 +494,13 @@ module m_derived_types end type cell_num_bounds type simplex_noise_params - logical, dimension(3) :: perturb_vel - real(wp), dimension(3) :: perturb_vel_freq - real(wp), dimension(3) :: perturb_vel_scale - real(wp), dimension(3, 3) :: perturb_vel_offset - - logical, dimension(1:num_fluids_max) :: perturb_dens - real(wp), dimension(1:num_fluids_max) :: perturb_dens_freq - real(wp), dimension(1:num_fluids_max) :: perturb_dens_scale + logical, dimension(3) :: perturb_vel + real(wp), dimension(3) :: perturb_vel_freq + real(wp), dimension(3) :: perturb_vel_scale + real(wp), dimension(3, 3) :: perturb_vel_offset + logical, dimension(1:num_fluids_max) :: perturb_dens + real(wp), dimension(1:num_fluids_max) :: perturb_dens_freq + real(wp), dimension(1:num_fluids_max) :: perturb_dens_scale real(wp), dimension(1:num_fluids_max, 3) :: perturb_dens_offset - end type - + end type simplex_noise_params end module m_derived_types - diff --git a/src/common/m_finite_differences.fpp b/src/common/m_finite_differences.fpp index e44b6905c0..eafd4fee1f 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -6,93 +6,83 @@ !> @brief Finite difference operators for computing divergence of velocity fields module m_finite_differences - use m_global_parameters implicit none - contains subroutine s_compute_fd_divergence(div, fields, ix_s, iy_s, iz_s) + type(scalar_field), intent(inout) :: div + type(scalar_field), intent(in) :: fields(1:3) + type(int_bounds_info), intent(in) :: ix_s, iy_s, iz_s + integer :: x, y, z !< Generic loop iterators + real(wp) :: divergence - type(scalar_field), intent(INOUT) :: div - type(scalar_field), intent(IN) :: fields(1:3) - type(int_bounds_info), intent(IN) :: ix_s, iy_s, iz_s - - integer :: x, y, z !< Generic loop iterators - - real(wp) :: divergence - - $:GPU_PARALLEL_LOOP(collapse=3, private='[x,y,z,divergence]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[x, y, z, divergence]') do x = ix_s%beg, ix_s%end do y = iy_s%beg, iy_s%end do z = iz_s%beg, iz_s%end - if (x == ix_s%beg) then - divergence = (-3._wp*fields(1)%sf(x, y, z) + 4._wp*fields(1)%sf(x + 1, y, z) - fields(1)%sf(x + 2, y, z))/(x_cc(x + 2) - x_cc(x)) + divergence = (-3._wp*fields(1)%sf(x, y, z) + 4._wp*fields(1)%sf(x + 1, y, z) - fields(1)%sf(x + 2, y, & + & z))/(x_cc(x + 2) - x_cc(x)) else if (x == ix_s%end) then - divergence = (+3._wp*fields(1)%sf(x, y, z) - 4._wp*fields(1)%sf(x - 1, y, z) + fields(1)%sf(x - 2, y, z))/(x_cc(x) - x_cc(x - 2)) + divergence = (+3._wp*fields(1)%sf(x, y, z) - 4._wp*fields(1)%sf(x - 1, y, z) + fields(1)%sf(x - 2, y, & + & z))/(x_cc(x) - x_cc(x - 2)) else divergence = (fields(1)%sf(x + 1, y, z) - fields(1)%sf(x - 1, y, z))/(x_cc(x + 1) - x_cc(x - 1)) end if if (n > 0) then if (y == iy_s%beg) then - divergence = divergence + (-3._wp*fields(2)%sf(x, y, z) + 4._wp*fields(2)%sf(x, y + 1, z) - fields(2)%sf(x, y + 2, z))/(y_cc(y + 2) - y_cc(y)) + divergence = divergence + (-3._wp*fields(2)%sf(x, y, z) + 4._wp*fields(2)%sf(x, y + 1, & + & z) - fields(2)%sf(x, y + 2, z))/(y_cc(y + 2) - y_cc(y)) else if (y == iy_s%end) then - divergence = divergence + (+3._wp*fields(2)%sf(x, y, z) - 4._wp*fields(2)%sf(x, y - 1, z) + fields(2)%sf(x, y - 2, z))/(y_cc(y) - y_cc(y - 2)) + divergence = divergence + (+3._wp*fields(2)%sf(x, y, z) - 4._wp*fields(2)%sf(x, y - 1, & + & z) + fields(2)%sf(x, y - 2, z))/(y_cc(y) - y_cc(y - 2)) else - divergence = divergence + (fields(2)%sf(x, y + 1, z) - fields(2)%sf(x, y - 1, z))/(y_cc(y + 1) - y_cc(y - 1)) + divergence = divergence + (fields(2)%sf(x, y + 1, z) - fields(2)%sf(x, y - 1, & + & z))/(y_cc(y + 1) - y_cc(y - 1)) end if end if if (p > 0) then if (z == iz_s%beg) then - divergence = divergence + (-3._wp*fields(3)%sf(x, y, z) + 4._wp*fields(3)%sf(x, y, z + 1) - fields(3)%sf(x, y, z + 2))/(z_cc(z + 2) - z_cc(z)) + divergence = divergence + (-3._wp*fields(3)%sf(x, y, z) + 4._wp*fields(3)%sf(x, y, & + & z + 1) - fields(3)%sf(x, y, z + 2))/(z_cc(z + 2) - z_cc(z)) else if (z == iz_s%end) then - divergence = divergence + (+3._wp*fields(3)%sf(x, y, z) - 4._wp*fields(3)%sf(x, y, z - 1) + fields(3)%sf(x, y, z - 2))/(z_cc(z) - z_cc(z - 2)) + divergence = divergence + (+3._wp*fields(3)%sf(x, y, z) - 4._wp*fields(3)%sf(x, y, & + & z - 1) + fields(3)%sf(x, y, z - 2))/(z_cc(z) - z_cc(z - 2)) else - divergence = divergence + (fields(3)%sf(x, y, z + 1) - fields(3)%sf(x, y, z - 1))/(z_cc(z + 1) - z_cc(z - 1)) + divergence = divergence + (fields(3)%sf(x, y, z + 1) - fields(3)%sf(x, y, & + & z - 1))/(z_cc(z + 1) - z_cc(z - 1)) end if end if div%sf(x, y, z) = div%sf(x, y, z) + divergence - end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_compute_fd_divergence - - !> The purpose of this subroutine is to compute the finite- - !! difference coefficients for the centered schemes utilized - !! in computations of first order spatial derivatives in the - !! s-coordinate direction. The s-coordinate direction refers - !! to the x-, y- or z-coordinate direction, depending on the - !! subroutine's inputs. Note that coefficients of up to 4th - !! order accuracy are available. - !! @param q Number of cells in the s-coordinate direction - !! @param s_cc Locations of the cell-centers in the s-coordinate direction - !! @param fd_coeff_s Finite-diff. coefficients in the s-coordinate direction - !! @param local_buff_size Size of the local buffer - !! @param fd_number_in Finite-difference number - !! @param fd_order_in Finite-difference order of accuracy - !! @param offset_s Optional offset bounds in the s-coordinate direction - subroutine s_compute_finite_difference_coefficients(q, s_cc, fd_coeff_s, local_buff_size, & - fd_number_in, fd_order_in, offset_s) - - integer :: lB, lE !< loop bounds - integer, intent(IN) :: q - integer, intent(IN) :: local_buff_size, fd_number_in, fd_order_in - type(int_bounds_info), optional, intent(IN) :: offset_s - real(wp), allocatable, dimension(:, :), intent(INOUT) :: fd_coeff_s - - real(wp), & - dimension(-local_buff_size:q + local_buff_size), & - intent(IN) :: s_cc - - integer :: i !< Generic loop iterator + !> The purpose of this subroutine is to compute the finite- difference coefficients for the centered schemes utilized in + !! computations of first order spatial derivatives in the s-coordinate direction. The s-coordinate direction refers to the x-, + !! y- or z-coordinate direction, depending on the subroutine's inputs. Note that coefficients of up to 4th order accuracy are + !! available. + !! @param q Number of cells in the s-coordinate direction + !! @param s_cc Locations of the cell-centers in the s-coordinate direction + !! @param fd_coeff_s Finite-diff. coefficients in the s-coordinate direction + !! @param local_buff_size Size of the local buffer + !! @param fd_number_in Finite-difference number + !! @param fd_order_in Finite-difference order of accuracy + !! @param offset_s Optional offset bounds in the s-coordinate direction + subroutine s_compute_finite_difference_coefficients(q, s_cc, fd_coeff_s, local_buff_size, fd_number_in, fd_order_in, offset_s) + integer :: lB, lE !< loop bounds + integer, intent(in) :: q + integer, intent(in) :: local_buff_size, fd_number_in, fd_order_in + type(int_bounds_info), optional, intent(in) :: offset_s + real(wp), allocatable, dimension(:,:), intent(inout) :: fd_coeff_s + real(wp), dimension(-local_buff_size:q + local_buff_size), intent(in) :: s_cc + integer :: i !< Generic loop iterator if (present(offset_s)) then lB = -offset_s%beg @@ -116,7 +106,7 @@ contains end do ! Computing the 2nd order finite-difference coefficients - elseif (fd_order_in == 2) then + else if (fd_order_in == 2) then do i = lB, lE fd_coeff_s(-1, i) = -1._wp/(s_cc(i + 1) - s_cc(i - 1)) fd_coeff_s(0, i) = 0._wp @@ -132,10 +122,6 @@ contains fd_coeff_s(1, i) = -fd_coeff_s(-1, i) fd_coeff_s(2, i) = -fd_coeff_s(-2, i) end do - end if - end subroutine s_compute_finite_difference_coefficients - end module m_finite_differences - diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index 5dccde311f..cb8ccaceb3 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -7,7 +7,6 @@ !> @brief Utility routines for bubble model setup, coordinate transforms, array sampling, and special functions module m_helper - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -16,33 +15,11 @@ module m_helper implicit none - private; - public :: s_comp_n_from_prim, & - s_comp_n_from_cons, & - s_initialize_bubbles_model, & - s_initialize_nonpoly, & - s_simpson, & - s_transcoeff, & - s_int_to_str, & - s_transform_vec, & - s_transform_triangle, & - s_transform_model, & - s_swap, & - f_cross, & - f_create_transform_matrix, & - f_create_bbox, & - s_print_2D_array, & - f_xor, & - f_logical_to_int, & - associated_legendre, & - real_ylm, & - double_factorial, & - factorial, & - f_cut_on, & - f_cut_off, & - s_downsample_data, & - s_upsample_data - + private; + public :: s_comp_n_from_prim, s_comp_n_from_cons, s_initialize_bubbles_model, s_initialize_nonpoly, s_simpson, s_transcoeff, & + & s_int_to_str, s_transform_vec, s_transform_triangle, s_transform_model, s_swap, f_cross, f_create_transform_matrix, & + & f_create_bbox, s_print_2D_array, f_xor, f_logical_to_int, associated_legendre, real_ylm, double_factorial, factorial, & + & f_cut_on, f_cut_off, s_downsample_data, s_upsample_data contains !> Computes the bubble number density n from the primitive variables @@ -52,42 +29,34 @@ contains !! @param weights is the quadrature weights subroutine s_comp_n_from_prim(vftmp, Rtmp, ntmp, weights) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: vftmp + real(wp), intent(in) :: vftmp real(wp), dimension(nb), intent(in) :: Rtmp - real(wp), intent(out) :: ntmp + real(wp), intent(out) :: ntmp real(wp), dimension(nb), intent(in) :: weights - - real(wp) :: R3 + real(wp) :: R3 R3 = dot_product(weights, Rtmp**3._wp) ntmp = (3._wp/(4._wp*pi))*vftmp/R3 - end subroutine s_comp_n_from_prim - !> @brief Computes the bubble number density from the conservative void fraction and weighted bubble radii. subroutine s_comp_n_from_cons(vftmp, nRtmp, ntmp, weights) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: vftmp + real(wp), intent(in) :: vftmp real(wp), dimension(nb), intent(in) :: nRtmp - real(wp), intent(out) :: ntmp + real(wp), intent(out) :: ntmp real(wp), dimension(nb), intent(in) :: weights - - real(wp) :: nR3 + real(wp) :: nR3 nR3 = dot_product(weights, nRtmp**3._wp) ntmp = sqrt((4._wp*pi/3._wp)*nR3/vftmp) - end subroutine s_comp_n_from_cons - !> @brief Prints a 2D real array to standard output, optionally dividing each element by a given scalar. impure subroutine s_print_2D_array(A, div) - - real(wp), dimension(:, :), intent(in) :: A - real(wp), optional, intent(in) :: div - - integer :: i, j - integer :: local_m, local_n - real(wp) :: c + real(wp), dimension(:,:), intent(in) :: A + real(wp), optional, intent(in) :: div + integer :: i, j + integer :: local_m, local_n + real(wp) :: c local_m = size(A, 1) local_n = size(A, 2) @@ -107,15 +76,9 @@ contains write (*, fmt="(A1)") " " end do write (*, fmt="(A1)") " " - end subroutine s_print_2D_array - - !> - !! bubbles_euler + polytropic - !! bubbles_euler + non-polytropic - !! bubbles_lagrange + non-polytropic + !> bubbles_euler + polytropic bubbles_euler + non-polytropic bubbles_lagrange + non-polytropic impure subroutine s_initialize_bubbles_model() - ! Allocate memory if (bubbles_euler) then @:ALLOCATE(weight(nb), R0(nb)) @@ -140,14 +103,11 @@ contains ! Initialize bubble variables call s_initialize_bubble_vars() - end subroutine s_initialize_bubbles_model - !> impure subroutine s_initialize_bubble_vars() - R0ref = bub_pp%R0ref; p0ref = bub_pp%p0ref - rho0ref = bub_pp%rho0ref; + rho0ref = bub_pp%rho0ref; ss = bub_pp%ss; pv = bub_pp%pv; vd = bub_pp%vd mu_l = bub_pp%mu_l; mu_v = bub_pp%mu_v; mu_g = bub_pp%mu_g gam_v = bub_pp%gam_v; gam_g = bub_pp%gam_g @@ -193,22 +153,17 @@ contains end if end if end if - end subroutine s_initialize_bubble_vars - !> Initializes non-polydisperse bubble modeling impure subroutine s_initialize_nonpoly() - integer :: ir + integer :: ir real(wp), dimension(nb) :: chi_vw0, cp_m0, k_m0, rho_m0, x_vw, omegaN, rhol0 - - real(wp), parameter :: k_poly = 1._wp !< + real(wp), parameter :: k_poly = 1._wp !< !! polytropic index used to compute isothermal natural frequency ! phi_vg & phi_gv (phi_gg = phi_vv = 1) (Eq. 2.22 in Ando 2010) - phi_vg = (1._wp + sqrt(mu_v/mu_g)*(M_g/M_v)**(0.25_wp))**2 & - /(sqrt(8._wp)*sqrt(1._wp + M_v/M_g)) - phi_gv = (1._wp + sqrt(mu_g/mu_v)*(M_v/M_g)**(0.25_wp))**2 & - /(sqrt(8._wp)*sqrt(1._wp + M_g/M_v)) + phi_vg = (1._wp + sqrt(mu_v/mu_g)*(M_g/M_v)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_v/M_g)) + phi_gv = (1._wp + sqrt(mu_g/mu_v)*(M_v/M_g)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_g/M_v)) ! internal bubble pressure pb0 = Eu + 2._wp/Web/R0 @@ -217,15 +172,13 @@ contains chi_vw0 = 1._wp/(1._wp + R_v/R_g*(pb0/pv - 1._wp)) ! specific heat for gas/vapor mixture - cp_m0 = chi_vw0*R_v*gam_v/(gam_v - 1._wp) & - + (1._wp - chi_vw0)*R_g*gam_g/(gam_g - 1._wp) + cp_m0 = chi_vw0*R_v*gam_v/(gam_v - 1._wp) + (1._wp - chi_vw0)*R_g*gam_g/(gam_g - 1._wp) ! mole fraction of vapor (Eq. 2.23 in Ando 2010) x_vw = M_g*chi_vw0/(M_v + (M_g - M_v)*chi_vw0) ! thermal conductivity for gas/vapor mixture (Eq. 2.21 in Ando 2010) - k_m0 = x_vw*k_v/(x_vw + (1._wp - x_vw)*phi_vg) & - + (1._wp - x_vw)*k_g/(x_vw*phi_gv + 1._wp - x_vw) + k_m0 = x_vw*k_v/(x_vw + (1._wp - x_vw)*phi_vg) + (1._wp - x_vw)*k_g/(x_vw*phi_gv + 1._wp - x_vw) k_g(:) = k_g(:)/k_m0(:) k_v(:) = k_v(:)/k_m0(:) @@ -242,26 +195,20 @@ contains ! natural frequencies (Eq. B.1) omegaN(:) = sqrt(3._wp*k_poly*Ca + 2._wp*(3._wp*k_poly - 1._wp)/(Web*R0))/R0/sqrt(rho0ref) do ir = 1, nb - call s_transcoeff(omegaN(ir)*R0(ir), Pe_T(ir)*R0(ir), & - Re_trans_T(ir), Im_trans_T(ir)) - call s_transcoeff(omegaN(ir)*R0(ir), Pe_c*R0(ir), & - Re_trans_c(ir), Im_trans_c(ir)) + call s_transcoeff(omegaN(ir)*R0(ir), Pe_T(ir)*R0(ir), Re_trans_T(ir), Im_trans_T(ir)) + call s_transcoeff(omegaN(ir)*R0(ir), Pe_c*R0(ir), Re_trans_c(ir), Im_trans_c(ir)) end do Im_trans_T = 0._wp - end subroutine s_initialize_nonpoly - !> Computes the transfer coefficient for the non-polytropic bubble compression process !! @param omega natural frequencies !! @param peclet Peclet number !! @param Re_trans Real part of the transport coefficients !! @param Im_trans Imaginary part of the transport coefficients elemental subroutine s_transcoeff(omega, peclet, Re_trans, Im_trans) - - real(wp), intent(in) :: omega, peclet + real(wp), intent(in) :: omega, peclet real(wp), intent(out) :: Re_trans, Im_trans - - complex(wp) :: imag, trans, c1, c2, c3 + complex(wp) :: imag, trans, c1, c2, c3 imag = (0._wp, 1._wp) @@ -272,27 +219,22 @@ contains Re_trans = trans Im_trans = aimag(trans) - end subroutine s_transcoeff - !> @brief Converts an integer to its trimmed string representation. elemental subroutine s_int_to_str(i, res) - - integer, intent(in) :: i + integer, intent(in) :: i character(len=*), intent(inout) :: res write (res, '(I0)') i res = trim(res) end subroutine s_int_to_str - !> Computes the Simpson weights for quadrature subroutine s_simpson(local_weight, local_R0) - real(wp), dimension(:), intent(inout) :: local_weight real(wp), dimension(:), intent(inout) :: local_R0 - integer :: ir - real(wp) :: R0mn, R0mx, dphi, tmp, sd - real(wp), dimension(nb) :: phi + integer :: ir + real(wp) :: R0mn, R0mx, dphi, tmp, sd + real(wp), dimension(nb) :: phi sd = poly_sigma R0mn = 0.8_wp*exp(-2.8_wp*sd) @@ -300,8 +242,7 @@ contains ! phi = ln( R0 ) & return R0 do ir = 1, nb - phi(ir) = log(R0mn) & - + (ir - 1._wp)*log(R0mx/R0mn)/(nb - 1._wp) + phi(ir) = log(R0mn) + (ir - 1._wp)*log(R0mx/R0mn)/(nb - 1._wp) local_R0(ir) = exp(phi(ir)) end do @@ -323,160 +264,116 @@ contains local_weight(1) = tmp*dphi/3._wp tmp = exp(-0.5_wp*(phi(nb)/sd)**2)/sqrt(2._wp*pi)/sd local_weight(nb) = tmp*dphi/3._wp - end subroutine s_simpson - !> This procedure computes the cross product of two vectors. !! @param a First vector. !! @param b Second vector. !! @return The cross product of the two vectors. pure function f_cross(a, b) result(c) - $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(3), intent(in) :: a, b - real(wp), dimension(3) :: c + real(wp), dimension(3) :: c c(1) = a(2)*b(3) - a(3)*b(2) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) end function f_cross - !> This procedure swaps two real numbers. !! @param lhs Left-hand side. !! @param rhs Right-hand side. elemental subroutine s_swap(lhs, rhs) - real(wp), intent(inout) :: lhs, rhs - real(wp) :: ltemp + real(wp) :: ltemp ltemp = lhs lhs = rhs rhs = ltemp end subroutine s_swap - !> This procedure creates a transformation matrix. !! @param param Parameters for the transformation. !! @param center Optional center point for the transformation. !! @return Transformation matrix. function f_create_transform_matrix(param, center) result(out_matrix) - - type(ic_model_parameters), intent(in) :: param + type(ic_model_parameters), intent(in) :: param real(wp), dimension(1:3), optional, intent(in) :: center - real(wp), dimension(1:4, 1:4) :: sc, rz, rx, ry, tr, t_back, t_to_origin, out_matrix - - sc = transpose(reshape([ & - param%scale(1), 0._wp, 0._wp, 0._wp, & - 0._wp, param%scale(2), 0._wp, 0._wp, & - 0._wp, 0._wp, param%scale(3), 0._wp, & - 0._wp, 0._wp, 0._wp, 1._wp], shape(sc))) - - rz = transpose(reshape([ & - cos(param%rotate(3)), -sin(param%rotate(3)), 0._wp, 0._wp, & - sin(param%rotate(3)), cos(param%rotate(3)), 0._wp, 0._wp, & - 0._wp, 0._wp, 1._wp, 0._wp, & - 0._wp, 0._wp, 0._wp, 1._wp], shape(rz))) - - rx = transpose(reshape([ & - 1._wp, 0._wp, 0._wp, 0._wp, & - 0._wp, cos(param%rotate(1)), -sin(param%rotate(1)), 0._wp, & - 0._wp, sin(param%rotate(1)), cos(param%rotate(1)), 0._wp, & - 0._wp, 0._wp, 0._wp, 1._wp], shape(rx))) - - ry = transpose(reshape([ & - cos(param%rotate(2)), 0._wp, sin(param%rotate(2)), 0._wp, & - 0._wp, 1._wp, 0._wp, 0._wp, & - -sin(param%rotate(2)), 0._wp, cos(param%rotate(2)), 0._wp, & - 0._wp, 0._wp, 0._wp, 1._wp], shape(ry))) - - tr = transpose(reshape([ & - 1._wp, 0._wp, 0._wp, param%translate(1), & - 0._wp, 1._wp, 0._wp, param%translate(2), & - 0._wp, 0._wp, 1._wp, param%translate(3), & - 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + real(wp), dimension(1:4, 1:4) :: sc, rz, rx, ry, tr, t_back, t_to_origin, out_matrix + + sc = transpose(reshape([param%scale(1), 0._wp, 0._wp, 0._wp, 0._wp, param%scale(2), 0._wp, 0._wp, 0._wp, 0._wp, & + & param%scale(3), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(sc))) + + rz = transpose(reshape([cos(param%rotate(3)), -sin(param%rotate(3)), 0._wp, 0._wp, sin(param%rotate(3)), & + & cos(param%rotate(3)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp, 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rz))) + + rx = transpose(reshape([1._wp, 0._wp, 0._wp, 0._wp, 0._wp, cos(param%rotate(1)), -sin(param%rotate(1)), 0._wp, 0._wp, & + & sin(param%rotate(1)), cos(param%rotate(1)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rx))) + + ry = transpose(reshape([cos(param%rotate(2)), 0._wp, sin(param%rotate(2)), 0._wp, 0._wp, 1._wp, 0._wp, 0._wp, & + & -sin(param%rotate(2)), 0._wp, cos(param%rotate(2)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(ry))) + + tr = transpose(reshape([1._wp, 0._wp, 0._wp, param%translate(1), 0._wp, 1._wp, 0._wp, param%translate(2), 0._wp, 0._wp, & + & 1._wp, param%translate(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) if (present(center)) then ! Translation matrix to move center to the origin - t_to_origin = transpose(reshape([ & - 1._wp, 0._wp, 0._wp, -center(1), & - 0._wp, 1._wp, 0._wp, -center(2), & - 0._wp, 0._wp, 1._wp, -center(3), & - 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + t_to_origin = transpose(reshape([1._wp, 0._wp, 0._wp, -center(1), 0._wp, 1._wp, 0._wp, -center(2), 0._wp, 0._wp, & + & 1._wp, -center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) ! Translation matrix to move center back to original position - t_back = transpose(reshape([ & - 1._wp, 0._wp, 0._wp, center(1), & - 0._wp, 1._wp, 0._wp, center(2), & - 0._wp, 0._wp, 1._wp, center(3), & - 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + t_back = transpose(reshape([1._wp, 0._wp, 0._wp, center(1), 0._wp, 1._wp, 0._wp, center(2), 0._wp, 0._wp, 1._wp, & + & center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) out_matrix = matmul(tr, matmul(t_back, matmul(ry, matmul(rx, matmul(rz, matmul(sc, t_to_origin)))))) else out_matrix = matmul(ry, matmul(rx, rz)) end if - end function f_create_transform_matrix - !> This procedure transforms a vector by a matrix. !! @param vec Vector to transform. !! @param matrix Transformation matrix. subroutine s_transform_vec(vec, matrix) - - real(wp), dimension(1:3), intent(inout) :: vec + real(wp), dimension(1:3), intent(inout) :: vec real(wp), dimension(1:4, 1:4), intent(in) :: matrix - - real(wp), dimension(1:4) :: tmp + real(wp), dimension(1:4) :: tmp tmp = matmul(matrix, [vec(1), vec(2), vec(3), 1._wp]) vec = tmp(1:3) - end subroutine s_transform_vec - !> This procedure transforms a triangle by a matrix, one vertex at a time. !! @param triangle Triangle to transform. !! @param matrix Transformation matrix. !! @param matrix_n Normal transformation matrix. subroutine s_transform_triangle(triangle, matrix, matrix_n) - - type(t_triangle), intent(inout) :: triangle + type(t_triangle), intent(inout) :: triangle real(wp), dimension(1:4, 1:4), intent(in) :: matrix, matrix_n - - integer :: i + integer :: i do i = 1, 3 - call s_transform_vec(triangle%v(i, :), matrix) + call s_transform_vec(triangle%v(i,:), matrix) end do call s_transform_vec(triangle%n(1:3), matrix_n) - end subroutine s_transform_triangle - !> This procedure transforms a model by a matrix, one triangle at a time. !! @param model Model to transform. !! @param matrix Transformation matrix. !! @param matrix_n Normal transformation matrix. subroutine s_transform_model(model, matrix, matrix_n) - - type(t_model), intent(inout) :: model + type(t_model), intent(inout) :: model real(wp), dimension(1:4, 1:4), intent(in) :: matrix, matrix_n - - integer :: i + integer :: i do i = 1, size(model%trs) call s_transform_triangle(model%trs(i), matrix, matrix_n) end do - end subroutine s_transform_model - !> This procedure creates a bounding box for a model. !! @param model Model to create bounding box for. !! @return Bounding box. function f_create_bbox(model) result(bbox) - type(t_model), intent(in) :: model - type(t_bbox) :: bbox - - integer :: i, j + type(t_bbox) :: bbox + integer :: i, j if (size(model%trs) == 0) then bbox%min = 0._wp @@ -484,37 +381,32 @@ contains return end if - bbox%min = model%trs(1)%v(1, :) - bbox%max = model%trs(1)%v(1, :) + bbox%min = model%trs(1)%v(1,:) + bbox%max = model%trs(1)%v(1,:) do i = 1, size(model%trs) do j = 1, 3 - bbox%min = min(bbox%min, model%trs(i)%v(j, :)) - bbox%max = max(bbox%max, model%trs(i)%v(j, :)) + bbox%min = min(bbox%min, model%trs(i)%v(j,:)) + bbox%max = max(bbox%max, model%trs(i)%v(j,:)) end do end do - end function f_create_bbox - !> This procedure performs xor on lhs and rhs. !! @param lhs logical input. !! @param rhs other logical input. !! @return xored result. elemental function f_xor(lhs, rhs) result(res) - logical, intent(in) :: lhs, rhs - logical :: res + logical :: res res = (lhs .and. .not. rhs) .or. (.not. lhs .and. rhs) end function f_xor - !> This procedure converts logical to 1 or 0. !! @param predicate A Logical argument. !! @return 1 if .true., 0 if .false.. elemental function f_logical_to_int(predicate) result(int) - logical, intent(in) :: predicate - integer :: int + integer :: int if (predicate) then int = 1 @@ -522,14 +414,13 @@ contains int = 0 end if end function f_logical_to_int - - !> Real spherical harmonic Y_lm(theta, phi). theta = polar angle from +z (acos(z/r)), - !! phi = atan2(y,x). Uses associated Legendre P_l^|m|(cos theta). Standard normalisation. + !> Real spherical harmonic Y_lm(theta, phi). theta = polar angle from +z (acos(z/r)), phi = atan2(y,x). Uses associated Legendre + !! P_l^|m|(cos theta). Standard normalisation. function real_ylm(theta, phi, l, m) result(Y) - integer, intent(in) :: l, m + integer, intent(in) :: l, m real(wp), intent(in) :: theta, phi - real(wp) :: Y, x, prefac - integer :: m_abs + real(wp) :: Y, x, prefac + integer :: m_abs m_abs = abs(m) if (m_abs > l) then @@ -546,21 +437,18 @@ contains Y = prefac*sqrt(2._wp)*associated_legendre(x, l, m_abs)*sin(m_abs*phi) end if end function real_ylm - - !> Associated Legendre polynomial P_l^m(x) (Ferrers function, Condon-Shortley phase). - !! Valid for integer l >= 0, 0 <= m <= l, and x in [-1,1]. Returns 0 for |m| > l or l < 0. - !! Formulas: DLMF 14.10.3 (recurrence in degree), Wikipedia "Associated Legendre polynomials" - !! (P_l^l and P_l^{l-1} identities). Recurrence: (l-m)P_l^m = (2l-1)x P_{l-1}^m - (l+m-1)P_{l-2}^m. + !> Associated Legendre polynomial P_l^m(x) (Ferrers function, Condon-Shortley phase). Valid for integer l >= 0, 0 <= m <= l, and + !! x in [-1,1]. Returns 0 for |m| > l or l < 0. Formulas: DLMF 14.10.3 (recurrence in degree), Wikipedia "Associated Legendre + !! polynomials" (P_l^l and P_l^{l-1} identities). Recurrence: (l-m)P_l^m = (2l-1)x P_{l-1}^m - (l+m-1)P_{l-2}^m. !! @param x argument (typically cos(theta)), should be in [-1,1] !! @param l degree (>= 0) !! @param m_order order (0 <= m_order <= l) !! @return result_P P_l^m(x) recursive function associated_legendre(x, l, m_order) result(result_P) - - integer, intent(in) :: l, m_order + integer, intent(in) :: l, m_order real(wp), intent(in) :: x - real(wp) :: result_P - real(wp) :: one_minus_x2 + real(wp) :: result_P + real(wp) :: one_minus_x2 ! Out-of-domain: P_l^m = 0 for |m| > l or l < 0 (standard convention) if (l < 0 .or. m_order < 0 .or. m_order > l) then @@ -570,106 +458,86 @@ contains if (m_order <= 0 .and. l <= 0) then result_P = 1._wp - elseif (l == 1 .and. m_order <= 0) then + else if (l == 1 .and. m_order <= 0) then result_P = x - elseif (l == 1 .and. m_order == 1) then + else if (l == 1 .and. m_order == 1) then one_minus_x2 = max(0._wp, 1._wp - x**2) result_P = -sqrt(one_minus_x2) - elseif (m_order == l) then + else if (m_order == l) then ! P_l^l(x) = (-1)^l (2l-1)!! (1-x^2)^(l/2). Use real exponent for odd l one_minus_x2 = max(0._wp, 1._wp - x**2) result_P = (-1)**l*real(double_factorial(2*l - 1), wp)*one_minus_x2**(0.5_wp*real(l, wp)) - elseif (m_order == l - 1) then + else if (m_order == l - 1) then result_P = x*(2*l - 1)*associated_legendre(x, l - 1, l - 1) else - result_P = ((2*l - 1)*x*associated_legendre(x, l - 1, m_order) - (l + m_order - 1)*associated_legendre(x, l - 2, m_order))/(l - m_order) + result_P = ((2*l - 1)*x*associated_legendre(x, l - 1, m_order) - (l + m_order - 1)*associated_legendre(x, l - 2, & + & m_order))/(l - m_order) end if - end function associated_legendre - !> This function calculates the double factorial value of an integer !! @param n_in is the input integer !! @return R is the double factorial value of n elemental function double_factorial(n_in) result(R_result) - - integer, intent(in) :: n_in - integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer + integer, intent(in) :: n_in + integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer integer(kind=int64_kind) :: R_result - integer :: i + integer :: i R_result = product((/(i, i=n_in, 1, -2)/)) - end function double_factorial - !> The following function calculates the factorial value of an integer !! @param n_in is the input integer !! @return R is the factorial value of n elemental function factorial(n_in) result(R_result) - - integer, intent(in) :: n_in - integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer + integer, intent(in) :: n_in + integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer integer(kind=int64_kind) :: R_result - - integer :: i + integer :: i R_result = product((/(i, i=n_in, 1, -1)/)) - end function factorial - - !> This function calculates a smooth cut-on function that is zero for x values - !! smaller than zero and goes to one. It can be used for generating smooth - !! initial conditions + !> This function calculates a smooth cut-on function that is zero for x values smaller than zero and goes to one. It can be used + !! for generating smooth initial conditions !! @param x is the input value !! @param eps is the smoothing parameter !! @return fx is the cut-on function evaluated at x function f_cut_on(x, eps) result(fx) - real(wp), intent(in) :: x, eps - real(wp) :: fx + real(wp) :: fx fx = 1 - f_gx(x/eps)/(f_gx(x/eps) + f_gx(1 - x/eps)) - end function f_cut_on - - !> This function calculates a smooth cut-off function that is one for x values - !! smaller than zero and goes to zero. It can be used for generating smooth - !! initial conditions + !> This function calculates a smooth cut-off function that is one for x values smaller than zero and goes to zero. It can be + !! used for generating smooth initial conditions !! @param x is the input value !! @param eps is the smoothing parameter !! @return fx is the cut-ff function evaluated at x function f_cut_off(x, eps) result(fx) - real(wp), intent(in) :: x, eps - real(wp) :: fx + real(wp) :: fx fx = f_gx(x/eps)/(f_gx(x/eps) + f_gx(1 - x/eps)) - end function f_cut_off - !> This function is a helper function for the functions f_cut_on and f_cut_off !! @param x is the input value !! @return gx is the result function f_gx(x) result(gx) - real(wp), intent(in) :: x - real(wp) :: gx + real(wp) :: gx if (x > 0) then gx = exp(-1._wp/x) else gx = 0._wp end if - end function f_gx - !> @brief Downsamples conservative variable fields by a factor of 3 in each direction using volume averaging. subroutine s_downsample_data(q_cons_vf, q_cons_temp, m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_cons_temp ! Down sampling variables - integer :: i, j, k, l - integer :: ix, iy, iz, x_id, y_id, z_id + integer :: i, j, k, l + integer :: ix, iy, iz, x_id, y_id, z_id integer, intent(inout) :: m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds m_ds = int((m + 1)/3) - 1 @@ -692,8 +560,8 @@ contains do iz = -1, 1 do iy = -1, 1 do ix = -1, 1 - q_cons_temp(i)%sf(j, k, l) = q_cons_temp(i)%sf(j, k, l) & - + (1._wp/27._wp)*q_cons_vf(i)%sf(x_id + ix, y_id + iy, z_id + iz) + q_cons_temp(i)%sf(j, k, l) = q_cons_temp(i)%sf(j, k, & + & l) + (1._wp/27._wp)*q_cons_vf(i)%sf(x_id + ix, y_id + iy, z_id + iz) end do end do end do @@ -701,23 +569,19 @@ contains end do end do end do - end subroutine s_downsample_data - !> @brief Upsamples conservative variable fields from a coarsened grid back to the original resolution using interpolation. subroutine s_upsample_data(q_cons_vf, q_cons_temp) - type(scalar_field), intent(inout), dimension(sys_size) :: q_cons_vf, q_cons_temp - integer :: i, j, k, l - integer :: ix, iy, iz - integer :: x_id, y_id, z_id - real(wp), dimension(4) :: temp + integer :: i, j, k, l + integer :: ix, iy, iz + integer :: x_id, y_id, z_id + real(wp), dimension(4) :: temp do l = 0, p do k = 0, n do j = 0, m do i = 1, sys_size - ix = int(j/3._wp) iy = int(k/3._wp) iz = int(l/3._wp) @@ -727,20 +591,20 @@ contains z_id = l - int(3*iz) - 1 temp(1) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy, iz) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy, iz) - temp(2) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy + y_id, iz) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy + y_id, iz) + temp(2) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy + y_id, iz) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, & + & iy + y_id, iz) temp(3) = (2._wp/3._wp)*temp(1) + (1._wp/3._wp)*temp(2) - temp(1) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy, iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy, iz + z_id) - temp(2) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy + y_id, iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy + y_id, iz + z_id) + temp(1) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy, iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, & + & iy, iz + z_id) + temp(2) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy + y_id, & + & iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy + y_id, iz + z_id) temp(4) = (2._wp/3._wp)*temp(1) + (1._wp/3._wp)*temp(2) q_cons_vf(i)%sf(j, k, l) = (2._wp/3._wp)*temp(3) + (1._wp/3._wp)*temp(4) - end do end do end do end do - end subroutine s_upsample_data - end module m_helper diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 0b430cb4d5..8ddba3d103 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -6,20 +6,13 @@ !> @brief Basic floating-point utilities: approximate equality, default detection, and coordinate bounds module m_helper_basic - use m_derived_types !< Definitions of the derived types implicit none - private; - public :: f_approx_equal, & - f_approx_in_array, & - f_is_default, & - f_all_default, & - f_is_integer, & - s_configure_coordinate_bounds, & - s_update_cell_bounds - + private; + public :: f_approx_equal, f_approx_in_array, f_is_default, f_all_default, f_is_integer, s_configure_coordinate_bounds, & + & s_update_cell_bounds contains !> This procedure checks if two floating point numbers of wp are within tolerance. @@ -29,9 +22,9 @@ contains !! @return Result of the comparison. logical elemental function f_approx_equal(a, b, tol_input) result(res) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: a, b + real(wp), intent(in) :: a, b real(wp), optional, intent(in) :: tol_input - real(wp) :: tol + real(wp) :: tol if (present(tol_input)) then tol = tol_input @@ -47,7 +40,6 @@ contains res = (abs(a - b)/min(abs(a) + abs(b), huge(a)) < tol) end if end function f_approx_equal - !> This procedure checks if the point numbers of wp belongs to another array are within tolerance. !! @param a First number. !! @param b Array that contains several point numbers. @@ -55,11 +47,11 @@ contains !! @return Result of the comparison. logical function f_approx_in_array(a, b, tol_input) result(res) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: a - real(wp), intent(in) :: b(:) + real(wp), intent(in) :: a + real(wp), intent(in) :: b(:) real(wp), optional, intent(in) :: tol_input - real(wp) :: tol - integer :: i + real(wp) :: tol + integer :: i res = .false. @@ -76,7 +68,6 @@ contains end if end do end function f_approx_in_array - !> Checks if a real(wp) variable is of default value. !! @param var Variable to check. logical elemental function f_is_default(var) result(res) @@ -85,7 +76,6 @@ contains res = f_approx_equal(var, dflt_real) end function f_is_default - !> Checks if ALL elements of a real(wp) array are of default value. !! @param var_array Array to check. logical function f_all_default(var_array) result(res) @@ -93,8 +83,8 @@ contains res = all(f_is_default(var_array)) - !logical :: res_array(size(var_array)) - !integer :: i + ! logical :: res_array(size(var_array)) + ! integer :: i ! do i = 1, size(var_array) ! res_array(i) = f_is_default(var_array(i)) @@ -102,7 +92,6 @@ contains ! res = all(res_array) end function f_all_default - !> Checks if a real(wp) variable is an integer. !! @param var Variable to check. logical elemental function f_is_integer(var) result(res) @@ -111,18 +100,16 @@ contains res = f_approx_equal(var, real(nint(var), wp)) end function f_is_integer + subroutine s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & + & bubbles_lagrange, m, n, p, num_dims, igr, ib) - subroutine s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, & - igr_order, buff_size, idwint, idwbuff, & - viscous, bubbles_lagrange, m, n, p, num_dims, igr, ib) - - integer, intent(in) :: recon_type, weno_polyn, muscl_polyn - integer, intent(in) :: m, n, p, num_dims, igr_order - integer, intent(inout) :: buff_size + integer, intent(in) :: recon_type, weno_polyn, muscl_polyn + integer, intent(in) :: m, n, p, num_dims, igr_order + integer, intent(inout) :: buff_size type(int_bounds_info), dimension(3), intent(inout) :: idwint, idwbuff - logical, intent(in) :: viscous, bubbles_lagrange - logical, intent(in) :: igr - logical, intent(in) :: ib + logical, intent(in) :: viscous, bubbles_lagrange + logical, intent(in) :: igr + logical, intent(in) :: ib ! Determining the number of cells that are needed in order to store ! sufficient boundary conditions data as to iterate the solution in @@ -130,13 +117,13 @@ contains ! the next one if (igr) then buff_size = (igr_order - 1)/2 + 2 - elseif (recon_type == WENO_TYPE) then + else if (recon_type == WENO_TYPE) then if (viscous) then buff_size = 2*weno_polyn + 2 else buff_size = weno_polyn + 2 end if - elseif (recon_type == MUSCL_TYPE) then + else if (recon_type == MUSCL_TYPE) then buff_size = muscl_polyn + 2 end if @@ -160,9 +147,7 @@ contains idwbuff(1)%end = idwint(1)%end - idwbuff(1)%beg idwbuff(2)%end = idwint(2)%end - idwbuff(2)%beg idwbuff(3)%end = idwint(3)%end - idwbuff(3)%beg - end subroutine s_configure_coordinate_bounds - !> Updates the min and max number of cells in each set of axes !! @param bounds Min ans max values to update !! @param m Number of cells in x-axis @@ -170,7 +155,7 @@ contains !! @param p Number of cells in z-axis elemental subroutine s_update_cell_bounds(bounds, m, n, p) type(cell_num_bounds), intent(out) :: bounds - integer, intent(in) :: m, n, p + integer, intent(in) :: m, n, p bounds%mn_max = max(m, n) bounds%np_max = max(n, p) @@ -180,7 +165,5 @@ contains bounds%np_min = min(n, p) bounds%mp_min = min(m, p) bounds%mnp_min = min(m, n, p) - end subroutine s_update_cell_bounds - end module m_helper_basic diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index 9683f4caac..0c24f936af 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -7,7 +7,6 @@ !> @brief Binary STL file reader and processor for immersed boundary geometry module m_model - use m_helper use m_mpi_proxy use m_derived_types @@ -18,13 +17,12 @@ module m_model private - public :: f_model_read, s_model_write, s_model_free, f_model_is_inside, models, gpu_ntrs, & - gpu_trs_v, gpu_trs_n, gpu_boundary_v, gpu_boundary_edge_count, & - gpu_total_vertices, stl_bounding_boxes + public :: f_model_read, s_model_write, s_model_free, f_model_is_inside, models, gpu_ntrs, gpu_trs_v, gpu_trs_n, & + & gpu_boundary_v, gpu_boundary_edge_count, gpu_total_vertices, stl_bounding_boxes ! Subroutines for STL immersed boundaries - public :: s_check_boundary, s_register_edge, f_model_is_inside_flat, & - s_distance_normals_3D, s_distance_normals_2D, s_pack_model_for_gpu + public :: s_check_boundary, s_register_edge, f_model_is_inside_flat, s_distance_normals_3D, s_distance_normals_2D, & + & s_pack_model_for_gpu #ifdef MFC_SIMULATION public :: s_instantiate_STL_models @@ -33,36 +31,29 @@ module m_model !! array of STL models that can be allocated and then used in IB marker and levelset compute type(t_model_array), allocatable, target :: models(:) !! GPU-friendly flat arrays for STL model data - integer, allocatable :: gpu_ntrs(:) - real(wp), allocatable, dimension(:, :, :, :) :: gpu_trs_v - real(wp), allocatable, dimension(:, :, :) :: gpu_trs_n - real(wp), allocatable, dimension(:, :, :, :) :: gpu_boundary_v - integer, allocatable :: gpu_boundary_edge_count(:) - integer, allocatable :: gpu_total_vertices(:) - real(wp), allocatable :: stl_bounding_boxes(:, :, :) - $:GPU_DECLARE(create='[gpu_ntrs,gpu_trs_v,gpu_trs_n,gpu_boundary_v,gpu_boundary_edge_count,gpu_total_vertices]') - + integer, allocatable :: gpu_ntrs(:) + real(wp), allocatable, dimension(:,:,:,:) :: gpu_trs_v + real(wp), allocatable, dimension(:,:,:) :: gpu_trs_n + real(wp), allocatable, dimension(:,:,:,:) :: gpu_boundary_v + integer, allocatable :: gpu_boundary_edge_count(:) + integer, allocatable :: gpu_total_vertices(:) + real(wp), allocatable :: stl_bounding_boxes(:,:,:) + $:GPU_DECLARE(create='[gpu_ntrs, gpu_trs_v, gpu_trs_n, gpu_boundary_v, gpu_boundary_edge_count, gpu_total_vertices]') contains !> This procedure reads a binary STL file. !! @param filepath Path to the STL file. !! @param model The binary of the STL file. impure subroutine s_read_stl_binary(filepath, model) - - character(LEN=*), intent(in) :: filepath - type(t_model), intent(out) :: model - - integer :: i, iunit, iostat - + character(LEN=*), intent(in) :: filepath + type(t_model), intent(out) :: model + integer :: i, iunit, iostat character(kind=c_char, len=80) :: header - integer(kind=c_int32_t) :: nTriangles + integer(kind=c_int32_t) :: nTriangles + real(kind=c_float) :: normal(3), v(3, 3), v_norm + integer(kind=c_int16_t) :: attribute - real(kind=c_float) :: normal(3), v(3, 3), v_norm - integer(kind=c_int16_t) :: attribute - - open (newunit=iunit, file=filepath, action='READ', & - form='UNFORMATTED', status='OLD', iostat=iostat, & - access='STREAM') + open (newunit=iunit, file=filepath, action='READ', form='UNFORMATTED', status='OLD', iostat=iostat, access='STREAM') if (iostat /= 0) then print *, "Error: could not open Binary STL file ", filepath @@ -83,7 +74,7 @@ contains allocate (model%trs(model%ntrs)) do i = 1, model%ntrs - read (iunit) normal(:), v(1, :), v(2, :), v(3, :), attribute + read (iunit) normal(:), v(1,:), v(2,:), v(3,:), attribute model%trs(i)%v = v model%trs(i)%n = normal @@ -92,26 +83,21 @@ contains end do close (iunit) - end subroutine s_read_stl_binary - !> This procedure reads an ASCII STL file. !! @param filepath Path to the STL file. !! @param model the STL file. impure subroutine s_read_stl_ascii(filepath, model) character(LEN=*), intent(in) :: filepath - type(t_model), intent(out) :: model - - integer :: i, j, iunit, iostat - character(80) :: line, buffered_line - logical :: is_buffered - real(wp) :: normal(3), v_norm + type(t_model), intent(out) :: model + integer :: i, j, iunit, iostat + character(80) :: line, buffered_line + logical :: is_buffered + real(wp) :: normal(3), v_norm is_buffered = .false. - open (newunit=iunit, file=filepath, action='READ', & - form='FORMATTED', status='OLD', iostat=iostat, & - access='STREAM') + open (newunit=iunit, file=filepath, action='READ', form='FORMATTED', status='OLD', iostat=iostat, access='STREAM') if (iostat /= 0) then print *, "Error: could not open ASCII STL file ", filepath @@ -180,7 +166,7 @@ contains end if call s_skip_ignored_lines(iunit, buffered_line, is_buffered) - read (line(7:), *) model%trs(i)%v(j, :) + read (line(7:), *) model%trs(i)%v(j,:) end do if (is_buffered) then @@ -205,22 +191,16 @@ contains i = i + 1 end do end subroutine s_read_stl_ascii - !> This procedure reads an STL file. !! @param filepath Path to the STL file. !! @param model the STL file. impure subroutine s_read_stl(filepath, model) - character(LEN=*), intent(in) :: filepath - type(t_model), intent(out) :: model + type(t_model), intent(out) :: model + integer :: iunit, iostat + character(80) :: line - integer :: iunit, iostat - - character(80) :: line - - open (newunit=iunit, file=filepath, action='READ', & - form='FORMATTED', status='OLD', iostat=iostat, & - access='STREAM') + open (newunit=iunit, file=filepath, action='READ', form='FORMATTED', status='OLD', iostat=iostat, access='STREAM') if (iostat /= 0) then print *, "Error: could not open STL file ", filepath @@ -237,26 +217,18 @@ contains else call s_read_stl_binary(filepath, model) end if - end subroutine s_read_stl - !> This procedure reads an OBJ file. !! @param filepath Path to the obj file. !! @param model The obj file. impure subroutine s_read_obj(filepath, model) + character(LEN=*), intent(in) :: filepath + type(t_model), intent(out) :: model + integer :: i, j, k, l, iv3, iunit, iostat, nVertices + real(wp), dimension(1:3), allocatable :: vertices(:,:) + character(80) :: line - character(LEN=*), intent(in) :: filepath - type(t_model), intent(out) :: model - - integer :: i, j, k, l, iv3, iunit, iostat, nVertices - - real(wp), dimension(1:3), allocatable :: vertices(:, :) - - character(80) :: line - - open (newunit=iunit, file=filepath, action='READ', & - form='FORMATTED', status='OLD', iostat=iostat, & - access='STREAM') + open (newunit=iunit, file=filepath, action='READ', form='FORMATTED', status='OLD', iostat=iostat, access='STREAM') if (iostat /= 0) then print *, "Error: could not open model file ", filepath @@ -294,13 +266,13 @@ contains case ("vt") case ("l ") case ("v ") - read (line(3:), *) vertices(i, :) + read (line(3:), *) vertices(i,:) i = i + 1 case ("f ") read (line(3:), *) k, l, iv3 - model%trs(j)%v(1, :) = vertices(k, :) - model%trs(j)%v(2, :) = vertices(l, :) - model%trs(j)%v(3, :) = vertices(iv3, :) + model%trs(j)%v(1,:) = vertices(k,:) + model%trs(j)%v(2,:) = vertices(l,:) + model%trs(j)%v(3,:) = vertices(iv3,:) j = j + 1 case default print *, "Error: unknown line type in OBJ file ", filepath @@ -313,17 +285,13 @@ contains deallocate (vertices) close (iunit) - end subroutine s_read_obj - !> This procedure reads a mesh from a file. !! @param filepath Path to the file to read. !! @return The model read from the file. impure function f_model_read(filepath) result(model) - character(LEN=*), intent(in) :: filepath - - type(t_model) :: model + type(t_model) :: model select case (filepath(len(trim(filepath)) - 3:len(trim(filepath)))) case (".stl") @@ -335,26 +303,20 @@ contains call s_mpi_abort() end select - end function f_model_read - !> This procedure writes a binary STL file. !! @param filepath Path to the STL file. !! @param model STL to write impure subroutine s_write_stl(filepath, model) - - character(LEN=*), intent(in) :: filepath - type(t_model), intent(in) :: model - - integer :: i, j, iunit, iostat - + character(LEN=*), intent(in) :: filepath + type(t_model), intent(in) :: model + integer :: i, j, iunit, iostat character(kind=c_char, len=80), parameter :: header = "Model file written by MFC." - integer(kind=c_int32_t) :: nTriangles - real(wp) :: normal(3), v(3) - integer(kind=c_int16_t) :: attribute + integer(kind=c_int32_t) :: nTriangles + real(wp) :: normal(3), v(3) + integer(kind=c_int16_t) :: attribute - open (newunit=iunit, file=filepath, action='WRITE', & - form='UNFORMATTED', iostat=iostat, access='STREAM') + open (newunit=iunit, file=filepath, action='WRITE', form='UNFORMATTED', iostat=iostat, access='STREAM') if (iostat /= 0) then print *, "Error: could not open STL file ", filepath @@ -376,7 +338,7 @@ contains write (iunit) normal do j = 1, 3 - v = model%trs(i)%v(j, :) + v = model%trs(i)%v(j,:) write (iunit) v(:) end do @@ -385,23 +347,17 @@ contains end do close (iunit) - end subroutine s_write_stl - !> This procedure writes an OBJ file. !! @param filepath Path to the obj file. !! @param model obj to write. impure subroutine s_write_obj(filepath, model) - character(LEN=*), intent(in) :: filepath - type(t_model), intent(in) :: model - - integer :: iunit, iostat + type(t_model), intent(in) :: model + integer :: iunit, iostat + integer :: i, j - integer :: i, j - - open (newunit=iunit, file=filepath, action='WRITE', & - form='FORMATTED', iostat=iostat, access='STREAM') + open (newunit=iunit, file=filepath, action='WRITE', form='FORMATTED', iostat=iostat, access='STREAM') if (iostat /= 0) then print *, "Error: could not open OBJ file ", filepath @@ -413,25 +369,21 @@ contains do i = 1, model%ntrs do j = 1, 3 - write (iunit, '(A, " ", (f30.20), " ", (f30.20), " ", (f30.20))') & - "v", model%trs(i)%v(j, 1), model%trs(i)%v(j, 2), model%trs(i)%v(j, 3) + write (iunit, '(A, " ", (f30.20), " ", (f30.20), " ", (f30.20))') "v", model%trs(i)%v(j, 1), model%trs(i)%v(j, & + & 2), model%trs(i)%v(j, 3) end do - write (iunit, '(A, " ", I0, " ", I0, " ", I0)') & - "f", i*3 - 2, i*3 - 1, i*3 + write (iunit, '(A, " ", I0, " ", I0, " ", I0)') "f", i*3 - 2, i*3 - 1, i*3 end do close (iunit) - end subroutine s_write_obj - !> This procedure writes a binary STL file. !! @param filepath Path to the file to write. !! @param model Model to write. impure subroutine s_model_write(filepath, model) - character(LEN=*), intent(in) :: filepath - type(t_model), intent(in) :: model + type(t_model), intent(in) :: model select case (filepath(len(trim(filepath)) - 3:len(trim(filepath)))) case (".stl") @@ -443,25 +395,18 @@ contains call s_mpi_abort() end select - end subroutine s_model_write - !> This procedure frees the memory allocated for an STL mesh. subroutine s_model_free(model) - type(t_model), intent(inout) :: model deallocate (model%trs) - end subroutine s_model_free - impure function f_read_line(iunit, line) result(bIsLine) - - integer, intent(in) :: iunit + integer, intent(in) :: iunit character(80), intent(out) :: line - - logical :: bIsLine - integer :: iostat + logical :: bIsLine + integer :: iostat bIsLine = .true. @@ -481,16 +426,13 @@ contains exit end do - end function f_read_line - !> @brief Reads the next non-comment line from a model file, using a buffered look-ahead mechanism. impure subroutine s_skip_ignored_lines(iunit, buffered_line, is_buffered) - integer, intent(in) :: iunit + integer, intent(in) :: iunit character(80), intent(inout) :: buffered_line - logical, intent(inout) :: is_buffered - - character(80) :: line + logical, intent(inout) :: is_buffered + character(80) :: line if (is_buffered) then line = buffered_line @@ -502,16 +444,13 @@ contains buffered_line = line is_buffered = .true. end subroutine s_skip_ignored_lines - - !> This function is used to replace the fortran random number - !! generator because the native generator is not compatible being called - !! from GPU routines/functions + !> This function is used to replace the fortran random number generator because the native generator is not compatible being + !! called from GPU routines/functions function f_model_random_number(seed) result(rval) - ! $:GPU_ROUTINE(parallelism='[seq]') integer, intent(inout) :: seed - real(wp) :: rval + real(wp) :: rval seed = ieor(seed, ishft(seed, 13)) seed = ieor(seed, ishft(seed, -17)) @@ -519,7 +458,6 @@ contains rval = abs(real(seed, wp))/real(huge(seed), wp) end function f_model_random_number - !> This procedure, recursively, finds whether a point is inside an octree. !! @param model Model to search in. !! @param point Point to test. @@ -527,26 +465,20 @@ contains !! @param spc Number of samples per cell. !! @return True if the point is inside the octree, false otherwise. impure function f_model_is_inside(model, point, spacing, spc) result(fraction) - ! $:GPU_ROUTINE(parallelism='[seq]') - type(t_model), intent(in) :: model + type(t_model), intent(in) :: model real(wp), dimension(1:3), intent(in) :: point real(wp), dimension(1:3), intent(in) :: spacing - integer, intent(in) :: spc - real(wp) :: phi, theta - integer :: rand_seed - - real(wp) :: fraction - - type(t_ray) :: ray - integer :: i, j, k, nInOrOut, nHits - - real(wp), dimension(1:spc, 1:3) :: ray_origins, ray_dirs - - rand_seed = int(point(1)*73856093._wp) + & - int(point(2)*19349663._wp) + & - int(point(3)*83492791._wp) + integer, intent(in) :: spc + real(wp) :: phi, theta + integer :: rand_seed + real(wp) :: fraction + type(t_ray) :: ray + integer :: i, j, k, nInOrOut, nHits + real(wp), dimension(1:spc, 1:3) :: ray_origins, ray_dirs + + rand_seed = int(point(1)*73856093._wp) + int(point(2)*19349663._wp) + int(point(3)*83492791._wp) if (rand_seed == 0) rand_seed = 1 ! generate our random collection or rays @@ -557,14 +489,14 @@ contains ! cast sample rays in all directions ray_dirs(i, k) = f_model_random_number(rand_seed) - 0.5_wp end do - ray_dirs(i, :) = ray_dirs(i, :)/sqrt(sum(ray_dirs(i, :)*ray_dirs(i, :))) + ray_dirs(i,:) = ray_dirs(i,:)/sqrt(sum(ray_dirs(i,:)*ray_dirs(i,:))) end do ! ray trace nInOrOut = 0 do i = 1, spc - ray%o = ray_origins(i, :) - ray%d = ray_dirs(i, :) + ray%o = ray_origins(i,:) + ray%d = ray_dirs(i,:) nHits = 0 do j = 1, model%ntrs @@ -580,35 +512,27 @@ contains end do fraction = real(nInOrOut)/real(spc) - end function f_model_is_inside - - !> This procedure determines if a point is inside a surface using - !! the generalized winding number (Jacobson et al., SIGGRAPH 2013). - !! In 3D, sums the solid angle subtended by each triangle (Van - !! Oosterom-Strackee formula). In 2D (p==0), sums the signed - !! angle subtended by each boundary edge. Returns ~1.0 inside, - !! ~0.0 outside. Unlike ray casting, this is robust to small + !> This procedure determines if a point is inside a surface using the generalized winding number (Jacobson et al., SIGGRAPH + !! 2013). In 3D, sums the solid angle subtended by each triangle (Van Oosterom-Strackee formula). In 2D (p==0), sums the signed + !! angle subtended by each boundary edge. Returns ~1.0 inside, ~0.0 outside. Unlike ray casting, this is robust to small !! triangles/edges and vertex winding order. !! @param ntrs Number of triangles in the model. !! @param pid Patch ID of this model. !! @param point Point to test. !! @return fraction Winding number (~1.0 inside, ~0.0 outside). function f_model_is_inside_flat(ntrs, pid, point) result(fraction) - $:GPU_ROUTINE(parallelism='[seq]') - integer, intent(in) :: ntrs - integer, intent(in) :: pid + integer, intent(in) :: ntrs + integer, intent(in) :: pid real(wp), dimension(1:3), intent(in) :: point - - real(wp) :: fraction - - real(wp) :: r1(3), r2(3), r3(3) - real(wp) :: r1_mag, r2_mag, r3_mag - real(wp) :: numerator, denominator - real(wp) :: d1(2), d2(2) - integer :: q + real(wp) :: fraction + real(wp) :: r1(3), r2(3), r3(3) + real(wp) :: r1_mag, r2_mag, r3_mag + real(wp) :: numerator, denominator + real(wp) :: d1(2), d2(2) + integer :: q fraction = 0.0_wp @@ -622,9 +546,7 @@ contains d2(2) = gpu_boundary_v(q, 2, 2, pid) - point(2) ! Signed angle = atan2(d1 x d2, d1 . d2) - fraction = fraction + atan2( & - d1(1)*d2(2) - d1(2)*d2(1), & - d1(1)*d2(1) + d1(2)*d2(2)) + fraction = fraction + atan2(d1(1)*d2(2) - d1(2)*d2(1), d1(1)*d2(1) + d1(2)*d2(2)) end do ! 2D winding number = total angle / (2*pi) @@ -633,9 +555,9 @@ contains ! 3D winding number: sum solid angles via Van ! Oosterom-Strackee formula. do q = 1, ntrs - r1 = gpu_trs_v(1, :, q, pid) - point - r2 = gpu_trs_v(2, :, q, pid) - point - r3 = gpu_trs_v(3, :, q, pid) - point + r1 = gpu_trs_v(1,:, q, pid) - point + r2 = gpu_trs_v(2,:, q, pid) - point + r3 = gpu_trs_v(3,:, q, pid) - point r1_mag = sqrt(dot_product(r1, r1)) r2_mag = sqrt(dot_product(r2, r2)) @@ -647,14 +569,11 @@ contains ! tan(Omega/2) = numerator / denominator ! numerator = scalar triple product r1 . (r2 x r3) - numerator = r1(1)*(r2(2)*r3(3) - r2(3)*r3(2)) & - + r1(2)*(r2(3)*r3(1) - r2(1)*r3(3)) & - + r1(3)*(r2(1)*r3(2) - r2(2)*r3(1)) + numerator = r1(1)*(r2(2)*r3(3) - r2(3)*r3(2)) + r1(2)*(r2(3)*r3(1) - r2(1)*r3(3)) + r1(3)*(r2(1)*r3(2) - r2(2) & + & *r3(1)) - denominator = r1_mag*r2_mag*r3_mag & - + dot_product(r1, r2)*r3_mag & - + dot_product(r2, r3)*r1_mag & - + dot_product(r3, r1)*r2_mag + denominator = r1_mag*r2_mag*r3_mag + dot_product(r1, r2)*r3_mag + dot_product(r2, r3)*r1_mag + dot_product(r3, & + & r1)*r2_mag fraction = fraction + atan2(numerator, denominator) end do @@ -663,32 +582,25 @@ contains ! by 2*pi to get winding number = sum(Omega)/(4*pi). fraction = fraction/(2.0_wp*acos(-1.0_wp)) end if - end function f_model_is_inside_flat - - !> This procedure checks if a ray intersects a triangle using the - !! Moller-Trumbore algorithm (barycentric coordinates). Unlike the - !! previous cross-product sign test, this is vertex winding-order - !! independent. + !> This procedure checks if a ray intersects a triangle using the Moller-Trumbore algorithm (barycentric coordinates). Unlike + !! the previous cross-product sign test, this is vertex winding-order independent. !! @param ray Ray. !! @param triangle Triangle. !! @return 1 if the ray intersects the triangle, 0 otherwise. function f_intersects_triangle(ray, triangle) result(intersects) - $:GPU_ROUTINE(parallelism='[seq]') - type(t_ray), intent(in) :: ray + type(t_ray), intent(in) :: ray type(t_triangle), intent(in) :: triangle - - integer :: intersects - - real(wp) :: edge1(3), edge2(3), h(3), s(3), q(3) - real(wp) :: a, f, u, v, t + integer :: intersects + real(wp) :: edge1(3), edge2(3), h(3), s(3), q(3) + real(wp) :: a, f, u, v, t intersects = 0 - edge1 = triangle%v(2, :) - triangle%v(1, :) - edge2 = triangle%v(3, :) - triangle%v(1, :) + edge1 = triangle%v(2,:) - triangle%v(1,:) + edge2 = triangle%v(3,:) - triangle%v(1,:) h = f_cross(ray%d, edge2) a = dot_product(edge1, h) @@ -697,7 +609,7 @@ contains if (abs(a) < max(1e-7_wp, 10.0_wp*epsilon(1.0_wp))) return f = 1.0_wp/a - s = ray%o - triangle%v(1, :) + s = ray%o - triangle%v(1,:) u = f*dot_product(s, h) if (u < 0.0_wp .or. u > 1.0_wp) return @@ -710,25 +622,21 @@ contains t = f*dot_product(edge2, q) if (t > 0.0_wp) intersects = 1 - end function f_intersects_triangle - !> This procedure checks and labels edges shared by two or more triangles facets of the 2D STL model. !! @param model Model to search in. !! @param boundary_vertex_count Output total boundary vertex count subroutine s_check_boundary(model, boundary_v, boundary_vertex_count, boundary_edge_count) - - type(t_model), intent(in) :: model - real(wp), allocatable, intent(out), dimension(:, :, :) :: boundary_v !< Output boundary vertices/normals - integer, intent(out) :: boundary_vertex_count, boundary_edge_count !< Output boundary vertex/edge count - - integer :: i, j !< Model index iterator - integer :: edge_count, edge_index, store_index !< Boundary edge index iterator - real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer - real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer - real(wp), dimension(1:(3*model%ntrs), 1:2, 1:2) :: temp_boundary_v !< Temporary boundary vertex buffer - integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges - real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges + type(t_model), intent(in) :: model + real(wp), allocatable, intent(out), dimension(:,:,:) :: boundary_v !< Output boundary vertices/normals + integer, intent(out) :: boundary_vertex_count, boundary_edge_count !< Output boundary vertex/edge count + integer :: i, j !< Model index iterator + integer :: edge_count, edge_index, store_index !< Boundary edge index iterator + real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer + real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer + real(wp), dimension(1:(3*model%ntrs), 1:2, 1:2) :: temp_boundary_v !< Temporary boundary vertex buffer + integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges + real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges ! Total number of edges in 2D STL edge_count = 3*model%ntrs @@ -756,19 +664,19 @@ contains end do ! Check all edges and count repeated edges - $:GPU_PARALLEL_LOOP(private='[i,j]', copy='[temp_boundary_v,edge_occurrence]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j]', copy='[temp_boundary_v, edge_occurrence]', collapse=2) do i = 1, edge_count do j = 1, edge_count if (i /= j) then - if (((abs(temp_boundary_v(i, 1, 1) - temp_boundary_v(j, 1, 1)) < threshold_edge_zero) .and. & - (abs(temp_boundary_v(i, 1, 2) - temp_boundary_v(j, 1, 2)) < threshold_edge_zero) .and. & - (abs(temp_boundary_v(i, 2, 1) - temp_boundary_v(j, 2, 1)) < threshold_edge_zero) .and. & - (abs(temp_boundary_v(i, 2, 2) - temp_boundary_v(j, 2, 2)) < threshold_edge_zero)) .or. & - ((abs(temp_boundary_v(i, 1, 1) - temp_boundary_v(j, 2, 1)) < threshold_edge_zero) .and. & - (abs(temp_boundary_v(i, 1, 2) - temp_boundary_v(j, 2, 2)) < threshold_edge_zero) .and. & - (abs(temp_boundary_v(i, 2, 1) - temp_boundary_v(j, 1, 1)) < threshold_edge_zero) .and. & - (abs(temp_boundary_v(i, 2, 2) - temp_boundary_v(j, 1, 2)) < threshold_edge_zero))) then - + if (((abs(temp_boundary_v(i, 1, 1) - temp_boundary_v(j, 1, & + & 1)) < threshold_edge_zero) .and. (abs(temp_boundary_v(i, 1, 2) - temp_boundary_v(j, 1, & + & 2)) < threshold_edge_zero) .and. (abs(temp_boundary_v(i, 2, 1) - temp_boundary_v(j, 2, & + & 1)) < threshold_edge_zero) .and. (abs(temp_boundary_v(i, 2, 2) - temp_boundary_v(j, 2, & + & 2)) < threshold_edge_zero)) .or. ((abs(temp_boundary_v(i, 1, 1) - temp_boundary_v(j, 2, & + & 1)) < threshold_edge_zero) .and. (abs(temp_boundary_v(i, 1, 2) - temp_boundary_v(j, 2, & + & 2)) < threshold_edge_zero) .and. (abs(temp_boundary_v(i, 2, 1) - temp_boundary_v(j, 1, & + & 1)) < threshold_edge_zero) .and. (abs(temp_boundary_v(i, 2, 2) - temp_boundary_v(j, 1, & + & 2)) < threshold_edge_zero))) then $:GPU_ATOMIC(atomic='update') edge_occurrence(i) = edge_occurrence(i) + 1 end if @@ -825,26 +733,21 @@ contains boundary_v(i, 3, 1) = xnormal/v_norm boundary_v(i, 3, 2) = ynormal/v_norm end do - end subroutine s_check_boundary - !> This procedure appends the edge end vertices to a temporary buffer. subroutine s_register_edge(temp_boundary_v, edge, edge_index, edge_count) - - integer, intent(inout) :: edge_index !< Edge index iterator - integer, intent(inout) :: edge_count !< Total number of edges - real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered + integer, intent(inout) :: edge_index !< Edge index iterator + integer, intent(inout) :: edge_count !< Total number of edges + real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered real(wp), dimension(1:edge_count, 1:2, 1:2), intent(inout) :: temp_boundary_v !< Temporary edge end vertex buffer ! Increment edge index and store the edge edge_index = edge_index + 1 temp_boundary_v(edge_index, 1, 1:2) = edge(1, 1:2) temp_boundary_v(edge_index, 2, 1:2) = edge(2, 1:2) - end subroutine s_register_edge - - !> This procedure determines the levelset distance and normals of 3D models - !! by computing the exact closest point via projection onto triangle surfaces. + !> This procedure determines the levelset distance and normals of 3D models by computing the exact closest point via projection + !! onto triangle surfaces. !! @param ntrs Number of triangles for this patch !! @param trs_v Flat GPU array of triangle vertices for all patches !! @param trs_n Flat GPU array of triangle normals for all patches @@ -855,31 +758,30 @@ contains subroutine s_distance_normals_3D(ntrs, pid, point, normals, distance) $:GPU_ROUTINE(parallelism='[seq]') - integer, intent(in) :: ntrs - integer, intent(in) :: pid - real(wp), dimension(1:3), intent(in) :: point + integer, intent(in) :: ntrs + integer, intent(in) :: pid + real(wp), dimension(1:3), intent(in) :: point real(wp), dimension(1:3), intent(out) :: normals - real(wp), intent(out) :: distance - - integer :: i, j, l - real(wp) :: dist_min, dist_proj, dist_v, dist_e, t - real(wp) :: v1(1:3), v2(1:3), v3(1:3) - real(wp) :: e0(1:3), e1(1:3), pv(1:3) - real(wp) :: n(1:3), proj(1:3), norm_vec(1:3) - real(wp) :: d, ndot, denom, norm_mag - real(wp) :: u, v_bary, w - real(wp) :: l00, l01, l11, l20, l21 - real(wp) :: edge(1:3), pe(1:3) - real(wp) :: verts(1:3, 1:3) + real(wp), intent(out) :: distance + integer :: i, j, l + real(wp) :: dist_min, dist_proj, dist_v, dist_e, t + real(wp) :: v1(1:3), v2(1:3), v3(1:3) + real(wp) :: e0(1:3), e1(1:3), pv(1:3) + real(wp) :: n(1:3), proj(1:3), norm_vec(1:3) + real(wp) :: d, ndot, denom, norm_mag + real(wp) :: u, v_bary, w + real(wp) :: l00, l01, l11, l20, l21 + real(wp) :: edge(1:3), pe(1:3) + real(wp) :: verts(1:3, 1:3) dist_min = initial_distance_buffer normals = 0._wp do i = 1, ntrs ! Triangle vertices - v1(:) = gpu_trs_v(1, :, i, pid) - v2(:) = gpu_trs_v(2, :, i, pid) - v3(:) = gpu_trs_v(3, :, i, pid) + v1(:) = gpu_trs_v(1,:, i, pid) + v2(:) = gpu_trs_v(2,:, i, pid) + v3(:) = gpu_trs_v(3,:, i, pid) ! Triangle normal n(:) = gpu_trs_n(:, i, pid) @@ -916,9 +818,7 @@ contains ! If projection is inside triangle if (u >= 0._wp .and. v_bary >= 0._wp .and. w >= 0._wp) then - dist_proj = sqrt((point(1) - proj(1))**2 + & - (point(2) - proj(2))**2 + & - (point(3) - proj(3))**2) + dist_proj = sqrt((point(1) - proj(1))**2 + (point(2) - proj(2))**2 + (point(3) - proj(3))**2) if (dist_proj < dist_min) then dist_min = dist_proj @@ -939,9 +839,7 @@ contains if (t >= 0._wp .and. t <= 1._wp) then proj(:) = verts(:, j) + t*edge(:) - dist_e = sqrt((point(1) - proj(1))**2 + & - (point(2) - proj(2))**2 + & - (point(3) - proj(3))**2) + dist_e = sqrt((point(1) - proj(1))**2 + (point(2) - proj(2))**2 + (point(3) - proj(3))**2) if (dist_e < dist_min) then dist_min = dist_e @@ -955,9 +853,7 @@ contains end if end if else if (t < 0._wp) then - dist_v = sqrt((point(1) - verts(1, j))**2 + & - (point(2) - verts(2, j))**2 + & - (point(3) - verts(3, j))**2) + dist_v = sqrt((point(1) - verts(1, j))**2 + (point(2) - verts(2, j))**2 + (point(3) - verts(3, j))**2) if (dist_v < dist_min) then dist_min = dist_v @@ -967,9 +863,8 @@ contains normals(:) = norm_vec(:) end if else - dist_v = sqrt((point(1) - verts(1, mod(j, 3) + 1))**2 + & - (point(2) - verts(2, mod(j, 3) + 1))**2 + & - (point(3) - verts(3, mod(j, 3) + 1))**2) + dist_v = sqrt((point(1) - verts(1, mod(j, 3) + 1))**2 + (point(2) - verts(2, mod(j, & + & 3) + 1))**2 + (point(3) - verts(3, mod(j, 3) + 1))**2) if (dist_v < dist_min) then dist_min = dist_v @@ -984,11 +879,9 @@ contains end do distance = dist_min - end subroutine s_distance_normals_3D - - !> This procedure determines the levelset distance and normals of 2D models - !! by computing the exact closest point via projection onto boundary edges. + !> This procedure determines the levelset distance and normals of 2D models by computing the exact closest point via projection + !! onto boundary edges. !! @param boundary_v Flat GPU array of boundary vertices/normals for all patches !! @param pid Patch index into the boundary_v array !! @param boundary_edge_count Total number of boundary edges for this patch @@ -998,16 +891,15 @@ contains subroutine s_distance_normals_2D(pid, boundary_edge_count, point, normals, distance) $:GPU_ROUTINE(parallelism='[seq]') - integer, intent(in) :: pid - integer, intent(in) :: boundary_edge_count - real(wp), dimension(1:3), intent(in) :: point + integer, intent(in) :: pid + integer, intent(in) :: boundary_edge_count + real(wp), dimension(1:3), intent(in) :: point real(wp), dimension(1:3), intent(out) :: normals - real(wp), intent(out) :: distance - - integer :: i - real(wp) :: dist_min, dist, t, norm_mag - real(wp) :: v1(1:2), v2(1:2), edge(1:2), pv(1:2) - real(wp) :: edge_len_sq, proj(1:2), norm(1:2), c + real(wp), intent(out) :: distance + integer :: i + real(wp) :: dist_min, dist, t, norm_mag + real(wp) :: v1(1:2), v2(1:2), edge(1:2), pv(1:2) + real(wp) :: edge_len_sq, proj(1:2), norm(1:2), c dist_min = initial_distance_buffer normals = 0._wp @@ -1059,31 +951,24 @@ contains end do distance = dist_min - end subroutine s_distance_normals_2D - #ifdef MFC_SIMULATION subroutine s_instantiate_STL_models() - ! Variables for IBM+STL - real(wp) :: normals(1:3) !< Boundary normal buffer - integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex - real(wp), allocatable, dimension(:, :, :) :: boundary_v !< Boundary vertex buffer - real(wp) :: dx_local, dy_local, dz_local !< Levelset distance buffer - - integer :: i, j, k !< Generic loop iterators - integer :: patch_id - - type(t_bbox) :: bbox, bbox_old - type(t_model) :: model - type(ic_model_parameters) :: params - - real(wp) :: eta - real(wp), dimension(1:3) :: point, model_center - real(wp) :: grid_mm(1:3, 1:2) - - real(wp), dimension(1:4, 1:4) :: transform, transform_n + real(wp) :: normals(1:3) !< Boundary normal buffer + integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex + real(wp), allocatable, dimension(:,:,:) :: boundary_v !< Boundary vertex buffer + real(wp) :: dx_local, dy_local, dz_local !< Levelset distance buffer + integer :: i, j, k !< Generic loop iterators + integer :: patch_id + type(t_bbox) :: bbox, bbox_old + type(t_model) :: model + type(ic_model_parameters) :: params + real(wp) :: eta + real(wp), dimension(1:3) :: point, model_center + real(wp) :: grid_mm(1:3, 1:2) + real(wp), dimension(1:4, 1:4) :: transform, transform_n dx_local = minval(dx); dy_local = minval(dy) if (p /= 0) dz_local = minval(dz) @@ -1093,7 +978,7 @@ contains do patch_id = 1, num_ibs if (patch_ib(patch_id)%geometry == 5 .or. patch_ib(patch_id)%geometry == 12) then allocate (models(patch_id)%model) - print *, " * Reading model: "//trim(patch_ib(patch_id)%model_filepath) + print *, " * Reading model: " // trim(patch_ib(patch_id)%model_filepath) model = f_model_read(patch_ib(patch_id)%model_filepath) params%scale(:) = patch_ib(patch_id)%model_scale(:) @@ -1141,13 +1026,13 @@ contains write (*, "(A, 3(2X, F20.10))") " > Cen:", (bbox%min(1:3) + bbox%max(1:3))/2._wp write (*, "(A, 3(2X, F20.10))") " > Max:", bbox%max(1:3) - grid_mm(1, :) = (/minval(x_cc(0:m)) - 0.5_wp*dx_local, maxval(x_cc(0:m)) + 0.5_wp*dx_local/) - grid_mm(2, :) = (/minval(y_cc(0:n)) - 0.5_wp*dy_local, maxval(y_cc(0:n)) + 0.5_wp*dy_local/) + grid_mm(1,:) = (/minval(x_cc(0:m)) - 0.5_wp*dx_local, maxval(x_cc(0:m)) + 0.5_wp*dx_local/) + grid_mm(2,:) = (/minval(y_cc(0:n)) - 0.5_wp*dy_local, maxval(y_cc(0:n)) + 0.5_wp*dy_local/) if (p > 0) then - grid_mm(3, :) = (/minval(z_cc(0:p)) - 0.5_wp*dz_local, maxval(z_cc(0:p)) + 0.5_wp*dz_local/) + grid_mm(3,:) = (/minval(z_cc(0:p)) - 0.5_wp*dz_local, maxval(z_cc(0:p)) + 0.5_wp*dz_local/) else - grid_mm(3, :) = (/0._wp, 0._wp/) + grid_mm(3,:) = (/0._wp, 0._wp/) end if write (*, "(A, 3(2X, F20.10))") " > Domain: Min:", grid_mm(:, 1) @@ -1209,15 +1094,14 @@ contains do pid = 1, num_ibs if (allocated(models(pid)%model)) then gpu_ntrs(pid) = models(pid)%ntrs - gpu_trs_v(:, :, 1:models(pid)%ntrs, pid) = models(pid)%trs_v + gpu_trs_v(:,:, 1:models(pid)%ntrs, pid) = models(pid)%trs_v gpu_trs_n(:, 1:models(pid)%ntrs, pid) = models(pid)%trs_n gpu_boundary_edge_count(pid) = models(pid)%boundary_edge_count gpu_total_vertices(pid) = models(pid)%total_vertices end if if (allocated(models(pid)%boundary_v) .and. p == 0) then - gpu_boundary_v(1:size(models(pid)%boundary_v, 1), & - 1:size(models(pid)%boundary_v, 2), & - 1:size(models(pid)%boundary_v, 3), pid) = models(pid)%boundary_v + gpu_boundary_v(1:size(models(pid)%boundary_v, 1), 1:size(models(pid)%boundary_v, 2), & + & 1:size(models(pid)%boundary_v, 3), pid) = models(pid)%boundary_v end if end do @@ -1227,23 +1111,20 @@ contains end if end if end block - end subroutine s_instantiate_STL_models - #endif subroutine s_pack_model_for_gpu(ma) type(t_model_array), intent(inout) :: ma - integer :: i + integer :: i ma%ntrs = ma%model%ntrs allocate (ma%trs_v(1:3, 1:3, 1:ma%ntrs)) allocate (ma%trs_n(1:3, 1:ma%ntrs)) do i = 1, ma%ntrs - ma%trs_v(:, :, i) = ma%model%trs(i)%v(:, :) + ma%trs_v(:,:, i) = ma%model%trs(i)%v(:,:) ma%trs_n(:, i) = ma%model%trs(i)%n(:) end do - end subroutine - + end subroutine s_pack_model_for_gpu end module m_model diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 97f4bb32cc..261a29bce5 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -7,7 +7,6 @@ !> @brief MPI communication layer: domain decomposition, halo exchange, reductions, and parallel I/O setup module m_mpi_common - #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -44,14 +43,11 @@ module m_mpi_common integer(kind=8) :: halo_size $:GPU_DECLARE(create='[halo_size]') - contains - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_mpi_common_module - #ifdef MFC_MPI ! Allocating buff_send/recv and. Please note that for the sake of ! simplicity, both variables are provided sufficient storage to hold @@ -65,14 +61,10 @@ contains if (n > 0) then if (p > 0) then - halo_size = nint(-1._wp + 1._wp*buff_size*(v_size)* & - & (m + 2*buff_size + 1)* & - & (n + 2*buff_size + 1)* & - & (p + 2*buff_size + 1)/ & - & (cells_bounds%mnp_min + 2*buff_size + 1)) + halo_size = nint(-1._wp + 1._wp*buff_size*(v_size)*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)*(p + 2*buff_size & + & + 1)/(cells_bounds%mnp_min + 2*buff_size + 1)) else - halo_size = -1 + buff_size*(v_size)* & - & (cells_bounds%mn_max + 2*buff_size + 1) + halo_size = -1 + buff_size*(v_size)*(cells_bounds%mn_max + 2*buff_size + 1) end if else halo_size = -1 + buff_size*(v_size) @@ -88,14 +80,10 @@ contains $:GPU_ENTER_DATA(create='[capture:buff_recv]') #endif #endif - end subroutine s_initialize_mpi_common_module - - !> The subroutine initializes the MPI execution environment - !! and queries both the number of processors which will be - !! available for the job and the local processor rank. + !> The subroutine initializes the MPI execution environment and queries both the number of processors which will be available + !! for the job and the local processor rank. impure subroutine s_mpi_initialize - #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors @@ -119,20 +107,16 @@ contains ! Local processor rank is 0 proc_rank = 0 #endif - end subroutine s_mpi_initialize - !! @param q_cons_vf Conservative variables !! @param ib_markers track if a cell is within the immersed boundary !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_initialize_mpi_data(q_cons_vf, ib_markers, beta) - type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - type(integer_field), optional, intent(in) :: ib_markers - type(scalar_field), intent(in), optional :: beta - - integer, dimension(num_dims) :: sizes_glb, sizes_loc - integer, dimension(1) :: airfoil_glb, airfoil_loc, airfoil_start + type(integer_field), optional, intent(in) :: ib_markers + type(scalar_field), intent(in), optional :: beta + integer, dimension(num_dims) :: sizes_glb, sizes_loc + integer, dimension(1) :: airfoil_glb, airfoil_loc, airfoil_start #ifdef MFC_MPI @@ -140,7 +124,7 @@ contains integer :: i, j integer :: ierr !< Generic flag used to identify and report MPI errors - !Altered system size for the lagrangian subgrid bubble model + ! Altered system size for the lagrangian subgrid bubble model integer :: alt_sys if (present(beta)) then @@ -157,7 +141,7 @@ contains MPI_IO_DATA%var(alt_sys)%sf => beta%sf(0:m, 0:n, 0:p) end if - !Additional variables pb and mv for non-polytropic qbmm + ! Additional variables pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = 1, nb do j = 1, nnode @@ -183,18 +167,17 @@ contains ! Define the view for each variable do i = 1, alt_sys - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, & - MPI_ORDER_FORTRAN, mpi_p, MPI_IO_DATA%view(i), ierr) + call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, mpi_p, & + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do #ifndef MFC_POST_PROCESS if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, & - MPI_ORDER_FORTRAN, mpi_p, MPI_IO_DATA%view(i), ierr) + call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, mpi_p, & + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) - end do end if #endif @@ -203,25 +186,18 @@ contains if (present(ib_markers)) then MPI_IO_IB_DATA%var%sf => ib_markers%sf(0:m, 0:n, 0:p) - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, & - MPI_ORDER_FORTRAN, MPI_INTEGER, MPI_IO_IB_DATA%view, ierr) + call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, MPI_INTEGER, & + & MPI_IO_IB_DATA%view, ierr) call MPI_TYPE_COMMIT(MPI_IO_IB_DATA%view, ierr) end if #endif - #endif - end subroutine s_initialize_mpi_data - !! @param q_cons_vf Conservative variables subroutine s_initialize_mpi_data_ds(q_cons_vf) - - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_cons_vf - - integer, dimension(num_dims) :: sizes_glb, sizes_loc - integer, dimension(3) :: sf_start_idx + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf + integer, dimension(num_dims) :: sizes_glb, sizes_loc + integer, dimension(3) :: sf_start_idx #ifdef MFC_MPI @@ -256,32 +232,27 @@ contains ! Define the view for each variable do i = 1, sys_size - call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_loc, sizes_loc, sf_start_idx, & - MPI_ORDER_FORTRAN, mpi_p, MPI_IO_DATA%view(i), ierr) + call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_loc, sizes_loc, sf_start_idx, MPI_ORDER_FORTRAN, mpi_p, & + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do #endif - end subroutine s_initialize_mpi_data_ds - !> @brief Gathers variable-length real vectors from all MPI ranks onto the root process. impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root) - - integer, intent(in) :: counts ! Array of vector lengths for each process - real(wp), intent(in), dimension(counts) :: my_vector ! Input vector on each process - integer, intent(in) :: root ! Rank of the root process - real(wp), allocatable, intent(out) :: gathered_vector(:) ! Gathered vector on the root process - - integer :: i - integer :: ierr !< Generic flag used to identify and report MPI errors - integer, allocatable :: recounts(:), displs(:) + integer, intent(in) :: counts ! Array of vector lengths for each process + real(wp), intent(in), dimension(counts) :: my_vector ! Input vector on each process + integer, intent(in) :: root ! Rank of the root process + real(wp), allocatable, intent(out) :: gathered_vector(:) ! Gathered vector on the root process + integer :: i + integer :: ierr !< Generic flag used to identify and report MPI errors + integer, allocatable :: recounts(:), displs(:) #ifdef MFC_MPI allocate (recounts(num_procs)) - call MPI_GATHER(counts, 1, MPI_INTEGER, recounts, 1, MPI_INTEGER, root, & - MPI_COMM_WORLD, ierr) + call MPI_GATHER(counts, 1, MPI_INTEGER, recounts, 1, MPI_INTEGER, root, MPI_COMM_WORLD, ierr) allocate (displs(size(recounts))) @@ -292,26 +263,20 @@ contains end do allocate (gathered_vector(sum(recounts))) - call MPI_GATHERV(my_vector, counts, mpi_p, gathered_vector, recounts, displs, mpi_p, & - root, MPI_COMM_WORLD, ierr) + call MPI_GATHERV(my_vector, counts, mpi_p, gathered_vector, recounts, displs, mpi_p, root, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_gather_data - !> @brief Gathers per-rank time step wall-clock times onto rank 0 for performance reporting. impure subroutine mpi_bcast_time_step_values(proc_time, time_avg) - real(wp), dimension(0:num_procs - 1), intent(inout) :: proc_time - real(wp), intent(inout) :: time_avg + real(wp), intent(inout) :: time_avg #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_GATHER(time_avg, 1, mpi_p, proc_time(0), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) - #endif - end subroutine mpi_bcast_time_step_values - !> @brief Prints a case file error with the prohibited condition and message, then aborts execution. impure subroutine s_prohibit_abort(condition, message) character(len=*), intent(in) :: condition, message @@ -325,32 +290,22 @@ contains print *, "" call s_mpi_abort(code=CASE_FILE_ERROR_CODE) end subroutine s_prohibit_abort - - !> The goal of this subroutine is to determine the global - !! extrema of the stability criteria in the computational - !! domain. This is performed by sifting through the local - !! extrema of each stability criterion. Note that each of - !! the local extrema is from a single process, within its - !! assigned section of the computational domain. Finally, - !! note that the global extrema values are only bookkeept - !! on the rank 0 processor. - !! @param icfl_max_loc Local maximum ICFL stability criterion - !! @param vcfl_max_loc Local maximum VCFL stability criterion - !! @param Rc_min_loc Local minimum Rc stability criterion - !! @param icfl_max_glb Global maximum ICFL stability criterion - !! @param vcfl_max_glb Global maximum VCFL stability criterion - !! @param Rc_min_glb Global minimum Rc stability criterion - impure subroutine s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, & - vcfl_max_loc, & - Rc_min_loc, & - icfl_max_glb, & - vcfl_max_glb, & - Rc_min_glb) - - real(wp), intent(in) :: icfl_max_loc - real(wp), intent(in) :: vcfl_max_loc - real(wp), intent(in) :: Rc_min_loc - + !> The goal of this subroutine is to determine the global extrema of the stability criteria in the computational domain. This is + !! performed by sifting through the local extrema of each stability criterion. Note that each of the local extrema is from a + !! single process, within its assigned section of the computational domain. Finally, note that the global extrema values are + !! only bookkeept on the rank 0 processor. + !! @param icfl_max_loc Local maximum ICFL stability criterion + !! @param vcfl_max_loc Local maximum VCFL stability criterion + !! @param Rc_min_loc Local minimum Rc stability criterion + !! @param icfl_max_glb Global maximum ICFL stability criterion + !! @param vcfl_max_glb Global maximum VCFL stability criterion + !! @param Rc_min_glb Global minimum Rc stability criterion + impure subroutine s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & + & Rc_min_glb) + + real(wp), intent(in) :: icfl_max_loc + real(wp), intent(in) :: vcfl_max_loc + real(wp), intent(in) :: Rc_min_loc real(wp), intent(out) :: icfl_max_glb real(wp), intent(out) :: vcfl_max_glb real(wp), intent(out) :: Rc_min_glb @@ -361,19 +316,12 @@ contains ! Reducing local extrema of ICFL, VCFL, CCFL and Rc numbers to their ! global extrema and bookkeeping the results on the rank 0 processor - call MPI_REDUCE(icfl_max_loc, icfl_max_glb, 1, & - mpi_p, MPI_MAX, 0, & - MPI_COMM_WORLD, ierr) + call MPI_REDUCE(icfl_max_loc, icfl_max_glb, 1, mpi_p, MPI_MAX, 0, MPI_COMM_WORLD, ierr) if (viscous) then - call MPI_REDUCE(vcfl_max_loc, vcfl_max_glb, 1, & - mpi_p, MPI_MAX, 0, & - MPI_COMM_WORLD, ierr) - call MPI_REDUCE(Rc_min_loc, Rc_min_glb, 1, & - mpi_p, MPI_MIN, 0, & - MPI_COMM_WORLD, ierr) + call MPI_REDUCE(vcfl_max_loc, vcfl_max_glb, 1, mpi_p, MPI_MAX, 0, MPI_COMM_WORLD, ierr) + call MPI_REDUCE(Rc_min_loc, Rc_min_glb, 1, mpi_p, MPI_MIN, 0, MPI_COMM_WORLD, ierr) end if - #else icfl_max_glb = icfl_max_loc @@ -382,139 +330,100 @@ contains vcfl_max_glb = vcfl_max_loc Rc_min_glb = Rc_min_loc end if - #endif #endif - end subroutine s_mpi_reduce_stability_criteria_extrema - - !> The following subroutine takes the input local variable - !! from all processors and reduces to the sum of all - !! values. The reduced variable is recorded back onto the - !! original local variable on each processor. - !! @param var_loc Some variable containing the local value which should be - !! reduced amongst all the processors in the communicator. - !! @param var_glb The globally reduced value + !> The following subroutine takes the input local variable from all processors and reduces to the sum of all values. The reduced + !! variable is recorded back onto the original local variable on each processor. + ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the + ! communicator. + !! @param var_glb The globally reduced value impure subroutine s_mpi_allreduce_sum(var_loc, var_glb) - - real(wp), intent(in) :: var_loc + real(wp), intent(in) :: var_loc real(wp), intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure - call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, & - MPI_SUM, MPI_COMM_WORLD, ierr) - + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - end subroutine s_mpi_allreduce_sum - - !> This subroutine follows the behavior of the s_mpi_allreduce_sum subroutine - !> with the additional feature that it reduces an array of vectors. + !> This subroutine follows the behavior of the s_mpi_allreduce_sum subroutine + !> with the additional feature that it reduces an array of vectors. impure subroutine s_mpi_allreduce_vectors_sum(var_loc, var_glb, num_vectors, vector_length) - - integer, intent(in) :: num_vectors, vector_length - real(wp), dimension(:, :), intent(in) :: var_loc - real(wp), dimension(:, :), intent(out) :: var_glb + integer, intent(in) :: num_vectors, vector_length + real(wp), dimension(:,:), intent(in) :: var_loc + real(wp), dimension(:,:), intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure if (loc(var_loc) == loc(var_glb)) then - call MPI_Allreduce(MPI_IN_PLACE, var_glb, num_vectors*vector_length, & - mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) + call MPI_Allreduce(MPI_IN_PLACE, var_glb, num_vectors*vector_length, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) else - call MPI_Allreduce(var_loc, var_glb, num_vectors*vector_length, & - mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) + call MPI_Allreduce(var_loc, var_glb, num_vectors*vector_length, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) end if - #else var_glb(1:num_vectors, 1:vector_length) = var_loc(1:num_vectors, 1:vector_length) #endif - end subroutine s_mpi_allreduce_vectors_sum - - !> The following subroutine takes the input local variable - !! from all processors and reduces to the sum of all - !! values. The reduced variable is recorded back onto the - !! original local variable on each processor. - !! @param var_loc Some variable containing the local value which should be - !! reduced amongst all the processors in the communicator. - !! @param var_glb The globally reduced value + !> The following subroutine takes the input local variable from all processors and reduces to the sum of all values. The reduced + !! variable is recorded back onto the original local variable on each processor. + ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the + ! communicator. + !! @param var_glb The globally reduced value impure subroutine s_mpi_allreduce_integer_sum(var_loc, var_glb) - - integer, intent(in) :: var_loc + integer, intent(in) :: var_loc integer, intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure - call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_INTEGER, & - MPI_SUM, MPI_COMM_WORLD, ierr) + call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) #else var_glb = var_loc #endif - end subroutine s_mpi_allreduce_integer_sum - - !> The following subroutine takes the input local variable - !! from all processors and reduces to the minimum of all - !! values. The reduced variable is recorded back onto the - !! original local variable on each processor. - !! @param var_loc Some variable containing the local value which should be - !! reduced amongst all the processors in the communicator. - !! @param var_glb The globally reduced value + !> The following subroutine takes the input local variable from all processors and reduces to the minimum of all values. The + !! reduced variable is recorded back onto the original local variable on each processor. + ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the + ! communicator. + !! @param var_glb The globally reduced value impure subroutine s_mpi_allreduce_min(var_loc, var_glb) - - real(wp), intent(in) :: var_loc + real(wp), intent(in) :: var_loc real(wp), intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure - call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, & - MPI_MIN, MPI_COMM_WORLD, ierr) - + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, MPI_COMM_WORLD, ierr) #endif - end subroutine s_mpi_allreduce_min - - !> The following subroutine takes the input local variable - !! from all processors and reduces to the maximum of all - !! values. The reduced variable is recorded back onto the - !! original local variable on each processor. - !! @param var_loc Some variable containing the local value which should be - !! reduced amongst all the processors in the communicator. - !! @param var_glb The globally reduced value + !> The following subroutine takes the input local variable from all processors and reduces to the maximum of all values. The + !! reduced variable is recorded back onto the original local variable on each processor. + ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the + ! communicator. + !! @param var_glb The globally reduced value impure subroutine s_mpi_allreduce_max(var_loc, var_glb) - - real(wp), intent(in) :: var_loc + real(wp), intent(in) :: var_loc real(wp), intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure - call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, & - MPI_MAX, MPI_COMM_WORLD, ierr) - + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MAX, MPI_COMM_WORLD, ierr) #endif - end subroutine s_mpi_allreduce_max - - !> The following subroutine takes the inputted variable and - !! determines its minimum value on the entire computational - !! domain. The result is stored back into inputted variable. - !! @param var_loc holds the local value to be reduced among - !! all the processors in communicator. On output, the variable holds - !! the minimum value, reduced amongst all of the local values. + !> The following subroutine takes the inputted variable and determines its minimum value on the entire computational domain. The + !! result is stored back into inputted variable. + ! ! @param var_loc holds the local value to be reduced among all the processors in communicator. On output, the variable holds + ! the minimum value, reduced amongst all of the local values. impure subroutine s_mpi_reduce_min(var_loc) - real(wp), intent(inout) :: var_loc #ifdef MFC_MPI @@ -525,62 +434,43 @@ contains ! Performing reduction procedure and eventually storing its result ! into the variable that was initially inputted into the subroutine - call MPI_REDUCE(var_loc, var_glb, 1, mpi_p, & - MPI_MIN, 0, MPI_COMM_WORLD, ierr) + call MPI_REDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, 0, MPI_COMM_WORLD, ierr) - call MPI_BCAST(var_glb, 1, mpi_p, & - 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(var_glb, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) var_loc = var_glb - #endif - end subroutine s_mpi_reduce_min - - !> The following subroutine takes the first element of the - !! 2-element inputted variable and determines its maximum - !! value on the entire computational domain. The result is - !! stored back into the first element of the variable while - !! the rank of the processor that is in charge of the sub- - !! domain containing the maximum is stored into the second - !! element of the variable. - !! @param var_loc On input, this variable holds the local value and processor rank, - !! which are to be reduced among all the processors in communicator. - !! On output, this variable holds the maximum value, reduced amongst - !! all of the local values, and the process rank to which the value - !! belongs. + !> The following subroutine takes the first element of the 2-element inputted variable and determines its maximum value on the + !! entire computational domain. The result is stored back into the first element of the variable while the rank of the processor + !! that is in charge of the sub- domain containing the maximum is stored into the second element of the variable. + ! ! @param var_loc On input, this variable holds the local value and processor rank, which are to be reduced among all the + ! processors in communicator. On output, this variable holds the maximum value, reduced amongst all of the local values, and the + ! process rank to which the value belongs. impure subroutine s_mpi_reduce_maxloc(var_loc) - real(wp), dimension(2), intent(inout) :: var_loc #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors - + integer :: ierr !< Generic flag used to identify and report MPI errors real(wp), dimension(2) :: var_glb !< !! Temporary storage variable that holds the reduced maximum value !! and the rank of the processor with which the value is associated ! Performing reduction procedure and eventually storing its result ! into the variable that was initially inputted into the subroutine - call MPI_REDUCE(var_loc, var_glb, 1, mpi_2p, & - MPI_MAXLOC, 0, MPI_COMM_WORLD, ierr) + call MPI_REDUCE(var_loc, var_glb, 1, mpi_2p, MPI_MAXLOC, 0, MPI_COMM_WORLD, ierr) - call MPI_BCAST(var_glb, 1, mpi_2p, & - 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(var_glb, 1, mpi_2p, 0, MPI_COMM_WORLD, ierr) var_loc = var_glb - #endif - end subroutine s_mpi_reduce_maxloc - !> The subroutine terminates the MPI execution environment. !! @param prnt error message to be printed !! @param code optional exit code impure subroutine s_mpi_abort(prnt, code) - character(len=*), intent(in), optional :: prnt - integer, intent(in), optional :: code + integer, intent(in), optional :: code #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors @@ -589,7 +479,6 @@ contains if (present(prnt)) then print *, prnt call flush (6) - end if #ifndef MFC_MPI @@ -606,65 +495,44 @@ contains call MPI_ABORT(MPI_COMM_WORLD, 1, ierr) end if #endif - end subroutine s_mpi_abort - - !>Halts all processes until all have reached barrier. + !> Halts all processes until all have reached barrier. impure subroutine s_mpi_barrier - #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Calling MPI_BARRIER call MPI_BARRIER(MPI_COMM_WORLD, ierr) - #endif - end subroutine s_mpi_barrier - !> The subroutine finalizes the MPI execution environment. impure subroutine s_mpi_finalize - #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Finalizing the MPI environment call MPI_FINALIZE(ierr) - #endif - end subroutine s_mpi_finalize - - !> The goal of this procedure is to populate the buffers of - !! the cell-average conservative variables by communicating - !! with the neighboring processors. - !! @param q_comm Cell-average conservative variables - !! @param mpi_dir MPI communication coordinate direction - !! @param pbc_loc Processor boundary condition (PBC) location - !! @param nVar Number of variables to communicate - !! @param pb_in Optional internal bubble pressure - !! @param mv_in Optional bubble mass velocity - subroutine s_mpi_sendrecv_variables_buffers(q_comm, & - mpi_dir, & - pbc_loc, & - nVar, & - pb_in, mv_in) - - type(scalar_field), dimension(1:), intent(inout) :: q_comm + !> The goal of this procedure is to populate the buffers of the cell-average conservative variables by communicating with the + !! neighboring processors. + !! @param q_comm Cell-average conservative variables + !! @param mpi_dir MPI communication coordinate direction + !! @param pbc_loc Processor boundary condition (PBC) location + !! @param nVar Number of variables to communicate + !! @param pb_in Optional internal bubble pressure + !! @param mv_in Optional bubble mass velocity + subroutine s_mpi_sendrecv_variables_buffers(q_comm, mpi_dir, pbc_loc, nVar, pb_in, mv_in) + type(scalar_field), dimension(1:), intent(inout) :: q_comm real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: mpi_dir, pbc_loc, nVar - - integer :: i, j, k, l, r, q !< Generic loop iterators - - integer :: buffer_counts(1:3), buffer_count - - type(int_bounds_info) :: boundary_conditions(1:3) - integer :: beg_end(1:2), grid_dims(1:3) - integer :: dst_proc, src_proc, recv_tag, send_tag - - logical :: beg_end_geq_0, qbmm_comm - - integer :: pack_offset, unpack_offset + integer, intent(in) :: mpi_dir, pbc_loc, nVar + integer :: i, j, k, l, r, q !< Generic loop iterators + integer :: buffer_counts(1:3), buffer_count + type(int_bounds_info) :: boundary_conditions(1:3) + integer :: beg_end(1:2), grid_dims(1:3) + integer :: dst_proc, src_proc, recv_tag, send_tag + logical :: beg_end_geq_0, qbmm_comm + integer :: pack_offset, unpack_offset #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors @@ -676,18 +544,12 @@ contains if (present(pb_in) .and. present(mv_in) .and. qbmm .and. .not. polytropic) then qbmm_comm = .true. v_size = nVar + 2*nb*nnode - buffer_counts = (/ & - buff_size*v_size*(n + 1)*(p + 1), & - buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), & - buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1) & - /) + buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), & + & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) else v_size = nVar - buffer_counts = (/ & - buff_size*v_size*(n + 1)*(p + 1), & - buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), & - buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1) & - /) + buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), & + & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) end if $:GPU_UPDATE(device='[v_size]') @@ -746,8 +608,7 @@ contains do j = 0, buff_size - 1 do i = nVar + 1, nVar + nnode do q = 1, nb - r = (i - 1) + (q - 1)*nnode + v_size* & - (j + buff_size*(k + (n + 1)*l)) + r = (i - 1) + (q - 1)*nnode + v_size*(j + buff_size*(k + (n + 1)*l)) buff_send(r) = real(pb_in(j + pack_offset, k, l, i - nVar, q), kind=wp) end do end do @@ -762,8 +623,7 @@ contains do j = 0, buff_size - 1 do i = nVar + 1, nVar + nnode do q = 1, nb - r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size* & - (j + buff_size*(k + (n + 1)*l)) + r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*(j + buff_size*(k + (n + 1)*l)) buff_send(r) = real(mv_in(j + pack_offset, k, l, i - nVar, q), kind=wp) end do end do @@ -778,9 +638,7 @@ contains do l = 0, p do k = 0, buff_size - 1 do j = -buff_size, m + buff_size - r = (i - 1) + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - (k + buff_size*l)) + r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*(k + buff_size*l)) buff_send(r) = real(q_comm(i)%sf(j, k + pack_offset, l), kind=wp) end do end do @@ -795,9 +653,8 @@ contains do k = 0, buff_size - 1 do j = -buff_size, m + buff_size do q = 1, nb - r = (i - 1) + (q - 1)*nnode + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - (k + buff_size*l)) + r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*(k & + & + buff_size*l)) buff_send(r) = real(pb_in(j, k + pack_offset, l, i - nVar, q), kind=wp) end do end do @@ -812,9 +669,8 @@ contains do k = 0, buff_size - 1 do j = -buff_size, m + buff_size do q = 1, nb - r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - (k + buff_size*l)) + r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & + & + 1)*(k + buff_size*l)) buff_send(r) = real(mv_in(j, k + pack_offset, l, i - nVar, q), kind=wp) end do end do @@ -829,9 +685,8 @@ contains do l = 0, buff_size - 1 do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size - r = (i - 1) + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)*l)) + r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n & + & + 2*buff_size + 1)*l)) buff_send(r) = real(q_comm(i)%sf(j, k, l + pack_offset), kind=wp) end do end do @@ -846,9 +701,8 @@ contains do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size do q = 1, nb - r = (i - 1) + (q - 1)*nnode + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)*l)) + r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & + & + buff_size) + (n + 2*buff_size + 1)*l)) buff_send(r) = real(pb_in(j, k, l + pack_offset, i - nVar, q), kind=wp) end do end do @@ -863,9 +717,8 @@ contains do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size do q = 1, nb - r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)*l)) + r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & + & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*l)) buff_send(r) = real(mv_in(j, k, l + pack_offset, i - nVar, q), kind=wp) end do end do @@ -887,13 +740,10 @@ contains #:call GPU_HOST_DATA(use_device_addr='[buff_send, buff_recv]') call nvtxStartRange("RHS-COMM-SENDRECV-RDMA") - call MPI_SENDRECV( & - buff_send, buffer_count, mpi_p, dst_proc, send_tag, & - buff_recv, buffer_count, mpi_p, src_proc, recv_tag, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, & + & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA - #:endcall GPU_HOST_DATA $:GPU_WAIT() #:else @@ -902,10 +752,8 @@ contains call nvtxEndRange call nvtxStartRange("RHS-COMM-SENDRECV-NO-RMDA") - call MPI_SENDRECV( & - buff_send, buffer_count, mpi_p, dst_proc, send_tag, & - buff_recv, buffer_count, mpi_p, src_proc, recv_tag, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, & + & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA @@ -916,10 +764,8 @@ contains end if #:endfor #else - call MPI_SENDRECV( & - buff_send, buffer_count, mpi_p, dst_proc, send_tag, & - buff_recv, buffer_count, mpi_p, src_proc, recv_tag, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, src_proc, recv_tag, & + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) #endif ! Unpack Received Buffer @@ -932,8 +778,7 @@ contains do k = 0, n do j = -buff_size, -1 do i = 1, nVar - r = (i - 1) + v_size* & - (j + buff_size*((k + 1) + (n + 1)*l)) + r = (i - 1) + v_size*(j + buff_size*((k + 1) + (n + 1)*l)) q_comm(i)%sf(j + unpack_offset, k, l) = real(buff_recv(r), kind=stp) #if defined(__INTEL_COMPILER) if (ieee_is_nan(q_comm(i)%sf(j + unpack_offset, k, l))) then @@ -954,8 +799,7 @@ contains do j = -buff_size, -1 do i = nVar + 1, nVar + nnode do q = 1, nb - r = (i - 1) + (q - 1)*nnode + v_size* & - (j + buff_size*((k + 1) + (n + 1)*l)) + r = (i - 1) + (q - 1)*nnode + v_size*(j + buff_size*((k + 1) + (n + 1)*l)) pb_in(j + unpack_offset, k, l, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -970,8 +814,7 @@ contains do j = -buff_size, -1 do i = nVar + 1, nVar + nnode do q = 1, nb - r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size* & - (j + buff_size*((k + 1) + (n + 1)*l)) + r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*(j + buff_size*((k + 1) + (n + 1)*l)) mv_in(j + unpack_offset, k, l, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -986,9 +829,7 @@ contains do l = 0, p do k = -buff_size, -1 do j = -buff_size, m + buff_size - r = (i - 1) + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + buff_size*l)) + r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + buff_size*l)) q_comm(i)%sf(j, k + unpack_offset, l) = real(buff_recv(r), kind=stp) #if defined(__INTEL_COMPILER) if (ieee_is_nan(q_comm(i)%sf(j, k + unpack_offset, l))) then @@ -1009,9 +850,8 @@ contains do k = -buff_size, -1 do j = -buff_size, m + buff_size do q = 1, nb - r = (i - 1) + (q - 1)*nnode + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + buff_size*l)) + r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & + & + buff_size) + buff_size*l)) pb_in(j, k + unpack_offset, l, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -1026,9 +866,8 @@ contains do k = -buff_size, -1 do j = -buff_size, m + buff_size do q = 1, nb - r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + buff_size*l)) + r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & + & + 1)*((k + buff_size) + buff_size*l)) mv_in(j, k + unpack_offset, l, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -1044,10 +883,8 @@ contains do l = -buff_size, -1 do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size - r = (i - 1) + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l + buff_size))) + r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n & + & + 2*buff_size + 1)*(l + buff_size))) q_comm(i)%sf(j, k, l + unpack_offset) = real(buff_recv(r), kind=stp) #if defined(__INTEL_COMPILER) if (ieee_is_nan(q_comm(i)%sf(j, k, l + unpack_offset))) then @@ -1068,10 +905,8 @@ contains do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size do q = 1, nb - r = (i - 1) + (q - 1)*nnode + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l + buff_size))) + r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & + & + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) pb_in(j, k, l + unpack_offset, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -1086,10 +921,8 @@ contains do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size do q = 1, nb - r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size* & - ((j + buff_size) + (m + 2*buff_size + 1)* & - ((k + buff_size) + (n + 2*buff_size + 1)* & - (l + buff_size))) + r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & + & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) mv_in(j, k, l + unpack_offset, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -1103,17 +936,11 @@ contains #:endfor call nvtxEndRange #endif - end subroutine s_mpi_sendrecv_variables_buffers - - !> The purpose of this procedure is to optimally decompose - !! the computational domain among the available processors. - !! This is performed by attempting to award each processor, - !! in each of the coordinate directions, approximately the - !! same number of cells, and then recomputing the affected - !! global parameters. + !> The purpose of this procedure is to optimally decompose the computational domain among the available processors. This is + !! performed by attempting to award each processor, in each of the coordinate directions, approximately the same number of + !! cells, and then recomputing the affected global parameters. subroutine s_mpi_decompose_computational_domain - #ifdef MFC_MPI integer :: num_procs_x, num_procs_y, num_procs_z !< @@ -1157,10 +984,8 @@ contains ! 3D Cartesian Processor Topology if (n > 0) then - if (p > 0) then if (fft_wrt) then - ! Initial estimate of optimal processor topology num_procs_x = 1 num_procs_y = 1 @@ -1170,36 +995,22 @@ contains ! Benchmarking the quality of this initial guess tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10._wp*abs((n + 1)/tmp_num_procs_y & - - (p + 1)/tmp_num_procs_z) + fct_min = 10._wp*abs((n + 1)/tmp_num_procs_y - (p + 1)/tmp_num_procs_z) ! Optimization of the initial processor topology do i = 1, num_procs - - if (mod(num_procs, i) == 0 & - .and. & - (n + 1)/i >= num_stcls_min*recon_order) then - + if (mod(num_procs, i) == 0 .and. (n + 1)/i >= num_stcls_min*recon_order) then tmp_num_procs_y = i tmp_num_procs_z = num_procs/i - if (fct_min >= abs((n + 1)/tmp_num_procs_y & - - (p + 1)/tmp_num_procs_z) & - .and. & - (p + 1)/tmp_num_procs_z & - >= & - num_stcls_min*recon_order) then - + if (fct_min >= abs((n + 1)/tmp_num_procs_y - (p + 1)/tmp_num_procs_z) .and. (p + 1) & + & /tmp_num_procs_z >= num_stcls_min*recon_order) then num_procs_y = i num_procs_z = num_procs/i - fct_min = abs((n + 1)/tmp_num_procs_y & - - (p + 1)/tmp_num_procs_z) + fct_min = abs((n + 1)/tmp_num_procs_y - (p + 1)/tmp_num_procs_z) ierr = 0 - end if - end if - end do else @@ -1218,38 +1029,23 @@ contains tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) + fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) ! Searching for optimal computational domain distribution do i = 1, num_procs - - if (mod(num_procs, i) == 0 & - .and. & - (m + 1)/i >= num_stcls_min*recon_order) then - + if (mod(num_procs, i) == 0 .and. (m + 1)/i >= num_stcls_min*recon_order) then tmp_num_procs_x = i tmp_num_procs_y = num_procs/i - if (fct_min >= abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) & - .and. & - (n + 1)/tmp_num_procs_y & - >= & - num_stcls_min*recon_order) then - + if (fct_min >= abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) .and. (n + 1) & + & /tmp_num_procs_y >= num_stcls_min*recon_order) then num_procs_x = i num_procs_y = num_procs/i - fct_min = abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) + fct_min = abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) ierr = 0 - end if - end if - end do - else ! Initial estimate of optimal processor topology @@ -1262,77 +1058,48 @@ contains tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z - fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) & - + 10._wp*abs((n + 1)/tmp_num_procs_y & - - (p + 1)/tmp_num_procs_z) + fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + 10._wp*abs((n + 1) & + & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) ! Optimization of the initial processor topology do i = 1, num_procs - - if (mod(num_procs, i) == 0 & - .and. & - (m + 1)/i >= num_stcls_min*recon_order) then - + if (mod(num_procs, i) == 0 .and. (m + 1)/i >= num_stcls_min*recon_order) then do j = 1, num_procs/i - - if (mod(num_procs/i, j) == 0 & - .and. & - (n + 1)/j >= num_stcls_min*recon_order) then - + if (mod(num_procs/i, j) == 0 .and. (n + 1)/j >= num_stcls_min*recon_order) then tmp_num_procs_x = i tmp_num_procs_y = j tmp_num_procs_z = num_procs/(i*j) - if (fct_min >= abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) & - + abs((n + 1)/tmp_num_procs_y & - - (p + 1)/tmp_num_procs_z) & - .and. & - (p + 1)/tmp_num_procs_z & - >= & - num_stcls_min*recon_order) & - then - + if (fct_min >= abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + abs((n + 1) & + & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) .and. (p + 1) & + & /tmp_num_procs_z >= num_stcls_min*recon_order) then num_procs_x = i num_procs_y = j num_procs_z = num_procs/(i*j) - fct_min = abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) & - + abs((n + 1)/tmp_num_procs_y & - - (p + 1)/tmp_num_procs_z) + fct_min = abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + abs((n + 1) & + & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) ierr = 0 - end if - end if - end do - end if - end do - end if end if ! Verifying that a valid decomposition of the computational ! domain has been established. If not, the simulation exits. if (proc_rank == 0 .and. ierr == -1) then - call s_mpi_abort('Unsupported combination of values '// & - 'of num_procs, m, n, p and '// & - 'weno/muscl/igr_order. Exiting.') + call s_mpi_abort('Unsupported combination of values ' // 'of num_procs, m, n, p and ' & + & // 'weno/muscl/igr_order. Exiting.') end if ! Creating new communicator using the Cartesian topology - call MPI_CART_CREATE(MPI_COMM_WORLD, 3, (/num_procs_x, & - num_procs_y, num_procs_z/), & - (/.true., .true., .true./), & - .false., MPI_COMM_CART, ierr) + call MPI_CART_CREATE(MPI_COMM_WORLD, 3, (/num_procs_x, num_procs_y, num_procs_z/), (/.true., .true., .true./), & + & .false., MPI_COMM_CART, ierr) ! Finding the Cartesian coordinates of the local process - call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, & - proc_coords, ierr) + call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, proc_coords, ierr) ! END: 3D Cartesian Processor Topology ! Global Parameters for z-direction @@ -1353,16 +1120,14 @@ contains ! Boundary condition at the beginning if (proc_coords(3) > 0 .or. (bc_z%beg == BC_PERIODIC .and. num_procs_z > 1)) then proc_coords(3) = proc_coords(3) - 1 - call MPI_CART_RANK(MPI_COMM_CART, proc_coords, & - bc_z%beg, ierr) + call MPI_CART_RANK(MPI_COMM_CART, proc_coords, bc_z%beg, ierr) proc_coords(3) = proc_coords(3) + 1 end if ! Boundary condition at the end if (proc_coords(3) < num_procs_z - 1 .or. (bc_z%end == BC_PERIODIC .and. num_procs_z > 1)) then proc_coords(3) = proc_coords(3) + 1 - call MPI_CART_RANK(MPI_COMM_CART, proc_coords, & - bc_z%end, ierr) + call MPI_CART_RANK(MPI_COMM_CART, proc_coords, bc_z%end, ierr) proc_coords(3) = proc_coords(3) - 1 end if @@ -1395,16 +1160,12 @@ contains dz = (z_domain%end - z_domain%beg)/real(p_glb + 1, wp) if (proc_coords(3) < rem_cells) then - z_domain%beg = z_domain%beg + dz*real((p + 1)* & - proc_coords(3)) - z_domain%end = z_domain%end - dz*real((p + 1)* & - (num_procs_z - proc_coords(3) - 1) & - - (num_procs_z - rem_cells)) + z_domain%beg = z_domain%beg + dz*real((p + 1)*proc_coords(3)) + z_domain%end = z_domain%end - dz*real((p + 1)*(num_procs_z - proc_coords(3) - 1) - (num_procs_z & + & - rem_cells)) else - z_domain%beg = z_domain%beg + dz*real((p + 1)* & - proc_coords(3) + rem_cells) - z_domain%end = z_domain%end - dz*real((p + 1)* & - (num_procs_z - proc_coords(3) - 1)) + z_domain%beg = z_domain%beg + dz*real((p + 1)*proc_coords(3) + rem_cells) + z_domain%end = z_domain%end - dz*real((p + 1)*(num_procs_z - proc_coords(3) - 1)) end if end if #endif @@ -1421,56 +1182,37 @@ contains ! Benchmarking the quality of this initial guess tmp_num_procs_x = num_procs_x tmp_num_procs_y = num_procs_y - fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) + fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) ! Optimization of the initial processor topology do i = 1, num_procs - - if (mod(num_procs, i) == 0 & - .and. & - (m + 1)/i >= num_stcls_min*recon_order) then - + if (mod(num_procs, i) == 0 .and. (m + 1)/i >= num_stcls_min*recon_order) then tmp_num_procs_x = i tmp_num_procs_y = num_procs/i - if (fct_min >= abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) & - .and. & - (n + 1)/tmp_num_procs_y & - >= & - num_stcls_min*recon_order) then - + if (fct_min >= abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) .and. (n + 1) & + & /tmp_num_procs_y >= num_stcls_min*recon_order) then num_procs_x = i num_procs_y = num_procs/i - fct_min = abs((m + 1)/tmp_num_procs_x & - - (n + 1)/tmp_num_procs_y) + fct_min = abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) ierr = 0 - end if - end if - end do ! Verifying that a valid decomposition of the computational ! domain has been established. If not, the simulation exits. if (proc_rank == 0 .and. ierr == -1) then - call s_mpi_abort('Unsupported combination of values '// & - 'of num_procs, m, n and '// & - 'weno/muscl/igr_order. Exiting.') + call s_mpi_abort('Unsupported combination of values ' // 'of num_procs, m, n and ' & + & // 'weno/muscl/igr_order. Exiting.') end if ! Creating new communicator using the Cartesian topology - call MPI_CART_CREATE(MPI_COMM_WORLD, 2, (/num_procs_x, & - num_procs_y/), (/.true., & - .true./), .false., MPI_COMM_CART, & - ierr) + call MPI_CART_CREATE(MPI_COMM_WORLD, 2, (/num_procs_x, num_procs_y/), (/.true., .true./), .false., MPI_COMM_CART, & + & ierr) ! Finding the Cartesian coordinates of the local process - call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 2, & - proc_coords, ierr) - + call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 2, proc_coords, ierr) end if ! END: 2D Cartesian Processor Topology @@ -1492,16 +1234,14 @@ contains ! Boundary condition at the beginning if (proc_coords(2) > 0 .or. (bc_y%beg == BC_PERIODIC .and. num_procs_y > 1)) then proc_coords(2) = proc_coords(2) - 1 - call MPI_CART_RANK(MPI_COMM_CART, proc_coords, & - bc_y%beg, ierr) + call MPI_CART_RANK(MPI_COMM_CART, proc_coords, bc_y%beg, ierr) proc_coords(2) = proc_coords(2) + 1 end if ! Boundary condition at the end if (proc_coords(2) < num_procs_y - 1 .or. (bc_y%end == BC_PERIODIC .and. num_procs_y > 1)) then proc_coords(2) = proc_coords(2) + 1 - call MPI_CART_RANK(MPI_COMM_CART, proc_coords, & - bc_y%end, ierr) + call MPI_CART_RANK(MPI_COMM_CART, proc_coords, bc_y%end, ierr) proc_coords(2) = proc_coords(2) - 1 end if @@ -1534,16 +1274,12 @@ contains dy = (y_domain%end - y_domain%beg)/real(n_glb + 1, wp) if (proc_coords(2) < rem_cells) then - y_domain%beg = y_domain%beg + dy*real((n + 1)* & - proc_coords(2)) - y_domain%end = y_domain%end - dy*real((n + 1)* & - (num_procs_y - proc_coords(2) - 1) & - - (num_procs_y - rem_cells)) + y_domain%beg = y_domain%beg + dy*real((n + 1)*proc_coords(2)) + y_domain%end = y_domain%end - dy*real((n + 1)*(num_procs_y - proc_coords(2) - 1) - (num_procs_y & + & - rem_cells)) else - y_domain%beg = y_domain%beg + dy*real((n + 1)* & - proc_coords(2) + rem_cells) - y_domain%end = y_domain%end - dy*real((n + 1)* & - (num_procs_y - proc_coords(2) - 1)) + y_domain%beg = y_domain%beg + dy*real((n + 1)*proc_coords(2) + rem_cells) + y_domain%end = y_domain%end - dy*real((n + 1)*(num_procs_y - proc_coords(2) - 1)) end if end if #endif @@ -1556,14 +1292,10 @@ contains num_procs_x = num_procs ! Creating new communicator using the Cartesian topology - call MPI_CART_CREATE(MPI_COMM_WORLD, 1, (/num_procs_x/), & - (/.true./), .false., MPI_COMM_CART, & - ierr) + call MPI_CART_CREATE(MPI_COMM_WORLD, 1, (/num_procs_x/), (/.true./), .false., MPI_COMM_CART, ierr) ! Finding the Cartesian coordinates of the local process - call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 1, & - proc_coords, ierr) - + call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 1, proc_coords, ierr) end if ! Global Parameters for x-direction @@ -1626,35 +1358,24 @@ contains dx = (x_domain%end - x_domain%beg)/real(m_glb + 1, wp) if (proc_coords(1) < rem_cells) then - x_domain%beg = x_domain%beg + dx*real((m + 1)* & - proc_coords(1)) - x_domain%end = x_domain%end - dx*real((m + 1)* & - (num_procs_x - proc_coords(1) - 1) & - - (num_procs_x - rem_cells)) + x_domain%beg = x_domain%beg + dx*real((m + 1)*proc_coords(1)) + x_domain%end = x_domain%end - dx*real((m + 1)*(num_procs_x - proc_coords(1) - 1) - (num_procs_x - rem_cells)) else - x_domain%beg = x_domain%beg + dx*real((m + 1)* & - proc_coords(1) + rem_cells) - x_domain%end = x_domain%end - dx*real((m + 1)* & - (num_procs_x - proc_coords(1) - 1)) + x_domain%beg = x_domain%beg + dx*real((m + 1)*proc_coords(1) + rem_cells) + x_domain%end = x_domain%end - dx*real((m + 1)*(num_procs_x - proc_coords(1) - 1)) end if end if #endif end if #endif - end subroutine s_mpi_decompose_computational_domain - - !> The goal of this procedure is to populate the buffers of - !! the grid variables by communicating with the neighboring - !! processors. Note that only the buffers of the cell-width - !! distributions are handled in such a way. This is because - !! the buffers of cell-boundary locations may be calculated - !! directly from those of the cell-width distributions. - !! @param mpi_dir MPI communication coordinate direction - !! @param pbc_loc Processor boundary condition (PBC) location + !> The goal of this procedure is to populate the buffers of the grid variables by communicating with the neighboring processors. + !! Note that only the buffers of the cell-width distributions are handled in such a way. This is because the buffers of + !! cell-boundary locations may be calculated directly from those of the cell-width distributions. + !! @param mpi_dir MPI communication coordinate direction + !! @param pbc_loc Processor boundary condition (PBC) location #ifndef MFC_PRE_PROCESS subroutine s_mpi_sendrecv_grid_variables_buffers(mpi_dir, pbc_loc) - integer, intent(in) :: mpi_dir integer, intent(in) :: pbc_loc @@ -1663,179 +1384,106 @@ contains ! MPI Communication in x-direction if (mpi_dir == 1) then + if (pbc_loc == -1) then ! PBC at the beginning - if (pbc_loc == -1) then ! PBC at the beginning - - if (bc_x%end >= 0) then ! PBC at the beginning and end + if (bc_x%end >= 0) then ! PBC at the beginning and end ! Send/receive buffer to/from bc_x%end/bc_x%beg - call MPI_SENDRECV( & - dx(m - buff_size + 1), buff_size, & - mpi_p, bc_x%end, 0, & - dx(-buff_size), buff_size, & - mpi_p, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - - else ! PBC at the beginning only + call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(-buff_size), buff_size, mpi_p, & + & bc_x%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else ! PBC at the beginning only ! Send/receive buffer to/from bc_x%beg/bc_x%beg - call MPI_SENDRECV( & - dx(0), buff_size, & - mpi_p, bc_x%beg, 1, & - dx(-buff_size), buff_size, & - mpi_p, bc_x%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - + call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(-buff_size), buff_size, mpi_p, bc_x%beg, 0, & + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if + else ! PBC at the end - else ! PBC at the end - - if (bc_x%beg >= 0) then ! PBC at the end and beginning + if (bc_x%beg >= 0) then ! PBC at the end and beginning ! Send/receive buffer to/from bc_x%beg/bc_x%end - call MPI_SENDRECV( & - dx(0), buff_size, & - mpi_p, bc_x%beg, 1, & - dx(m + 1), buff_size, & - mpi_p, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - - else ! PBC at the end only + call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(m + 1), buff_size, mpi_p, bc_x%end, 1, & + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else ! PBC at the end only ! Send/receive buffer to/from bc_x%end/bc_x%end - call MPI_SENDRECV( & - dx(m - buff_size + 1), buff_size, & - mpi_p, bc_x%end, 0, & - dx(m + 1), buff_size, & - mpi_p, bc_x%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - + call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(m + 1), buff_size, mpi_p, & + & bc_x%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if - end if ! END: MPI Communication in x-direction ! MPI Communication in y-direction - elseif (mpi_dir == 2) then + else if (mpi_dir == 2) then + if (pbc_loc == -1) then ! PBC at the beginning - if (pbc_loc == -1) then ! PBC at the beginning - - if (bc_y%end >= 0) then ! PBC at the beginning and end + if (bc_y%end >= 0) then ! PBC at the beginning and end ! Send/receive buffer to/from bc_y%end/bc_y%beg - call MPI_SENDRECV( & - dy(n - buff_size + 1), buff_size, & - mpi_p, bc_y%end, 0, & - dy(-buff_size), buff_size, & - mpi_p, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - - else ! PBC at the beginning only + call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(-buff_size), buff_size, mpi_p, & + & bc_y%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else ! PBC at the beginning only ! Send/receive buffer to/from bc_y%beg/bc_y%beg - call MPI_SENDRECV( & - dy(0), buff_size, & - mpi_p, bc_y%beg, 1, & - dy(-buff_size), buff_size, & - mpi_p, bc_y%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - + call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(-buff_size), buff_size, mpi_p, bc_y%beg, 0, & + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if + else ! PBC at the end - else ! PBC at the end - - if (bc_y%beg >= 0) then ! PBC at the end and beginning + if (bc_y%beg >= 0) then ! PBC at the end and beginning ! Send/receive buffer to/from bc_y%beg/bc_y%end - call MPI_SENDRECV( & - dy(0), buff_size, & - mpi_p, bc_y%beg, 1, & - dy(n + 1), buff_size, & - mpi_p, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - - else ! PBC at the end only + call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(n + 1), buff_size, mpi_p, bc_y%end, 1, & + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else ! PBC at the end only ! Send/receive buffer to/from bc_y%end/bc_y%end - call MPI_SENDRECV( & - dy(n - buff_size + 1), buff_size, & - mpi_p, bc_y%end, 0, & - dy(n + 1), buff_size, & - mpi_p, bc_y%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - + call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(n + 1), buff_size, mpi_p, & + & bc_y%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if - end if ! END: MPI Communication in y-direction ! MPI Communication in z-direction else - if (pbc_loc == -1) then ! PBC at the beginning + if (pbc_loc == -1) then ! PBC at the beginning - if (bc_z%end >= 0) then ! PBC at the beginning and end + if (bc_z%end >= 0) then ! PBC at the beginning and end ! Send/receive buffer to/from bc_z%end/bc_z%beg - call MPI_SENDRECV( & - dz(p - buff_size + 1), buff_size, & - mpi_p, bc_z%end, 0, & - dz(-buff_size), buff_size, & - mpi_p, bc_z%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - - else ! PBC at the beginning only + call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(-buff_size), buff_size, mpi_p, & + & bc_z%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else ! PBC at the beginning only ! Send/receive buffer to/from bc_z%beg/bc_z%beg - call MPI_SENDRECV( & - dz(0), buff_size, & - mpi_p, bc_z%beg, 1, & - dz(-buff_size), buff_size, & - mpi_p, bc_z%beg, 0, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - + call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(-buff_size), buff_size, mpi_p, bc_z%beg, 0, & + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if + else ! PBC at the end - else ! PBC at the end - - if (bc_z%beg >= 0) then ! PBC at the end and beginning + if (bc_z%beg >= 0) then ! PBC at the end and beginning ! Send/receive buffer to/from bc_z%beg/bc_z%end - call MPI_SENDRECV( & - dz(0), buff_size, & - mpi_p, bc_z%beg, 1, & - dz(p + 1), buff_size, & - mpi_p, bc_z%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - - else ! PBC at the end only + call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(p + 1), buff_size, mpi_p, bc_z%end, 1, & + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + else ! PBC at the end only ! Send/receive buffer to/from bc_z%end/bc_z%end - call MPI_SENDRECV( & - dz(p - buff_size + 1), buff_size, & - mpi_p, bc_z%end, 0, & - dz(p + 1), buff_size, & - mpi_p, bc_z%end, 1, & - MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - + call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(p + 1), buff_size, mpi_p, & + & bc_z%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if - end if - end if ! END: MPI Communication in z-direction #endif - end subroutine s_mpi_sendrecv_grid_variables_buffers #endif !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_mpi_common_module - #ifdef MFC_MPI deallocate (buff_send, buff_recv) #endif - end subroutine s_finalize_mpi_common_module - end module m_mpi_common diff --git a/src/common/m_nvtx.f90 b/src/common/m_nvtx.f90 index 449401128b..e38997229b 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -4,30 +4,26 @@ !> @brief NVIDIA NVTX profiling API bindings for GPU performance instrumentation module m_nvtx - use iso_c_binding implicit none - integer, private :: col(7) = [ & - int(Z'0000ff00'), int(Z'000000ff'), int(Z'00ffff00'), & - int(Z'00ff00ff'), int(Z'0000ffff'), int(Z'00ff0000'), & - int(Z'00ffffff') & - ] + integer, private :: col(7) = [int(Z'0000ff00'), int(Z'000000ff'), int(Z'00ffff00'), int(Z'00ff00ff'), int(Z'0000ffff'), & + & int(Z'00ff0000'), int(Z'00ffffff')] character(len=256), private :: tempName type, bind(C) :: nvtxEventAttributes integer(c_int16_t) :: version = 1 - integer(c_int16_t) :: size = 48 ! - integer(c_int) :: category = 0 - integer(c_int) :: colorType = 1 ! NVTX_COLOR_ARGB = 1 - integer(c_int) :: color - integer(c_int) :: payloadType = 0 ! NVTX_PAYLOAD_UNKNOWN = 0 - integer(c_int) :: reserved0 - integer(c_int64_t) :: payload ! union uint,int,double - integer(c_int) :: messageType = 1 ! NVTX_MESSAGE_TYPE_ASCII = 1 - type(c_ptr) :: message ! ascii char + integer(c_int16_t) :: size = 48 ! + integer(c_int) :: category = 0 + integer(c_int) :: colorType = 1 ! NVTX_COLOR_ARGB = 1 + integer(c_int) :: color + integer(c_int) :: payloadType = 0 ! NVTX_PAYLOAD_UNKNOWN = 0 + integer(c_int) :: reserved0 + integer(c_int64_t) :: payload ! union uint,int,double + integer(c_int) :: messageType = 1 ! NVTX_MESSAGE_TYPE_ASCII = 1 + type(c_ptr) :: message ! ascii char end type nvtxEventAttributes #if defined(MFC_GPU) && defined(__PGI) @@ -37,15 +33,14 @@ module m_nvtx subroutine nvtxRangePushA(name) bind(C, name='nvtxRangePushA') use iso_c_binding - character(kind=c_char, len=*), intent(IN) :: name + character(kind=c_char, len=*), intent(in) :: name end subroutine nvtxRangePushA - ! push range with custom label and custom color subroutine nvtxRangePushEx(event) bind(C, name='nvtxRangePushEx') use iso_c_binding import :: nvtxEventAttributes - type(nvtxEventAttributes), intent(IN) :: event + type(nvtxEventAttributes), intent(in) :: event end subroutine nvtxRangePushEx end interface nvtxRangePush @@ -53,20 +48,18 @@ end subroutine nvtxRangePushEx subroutine nvtxRangePop() bind(C, name='nvtxRangePop') end subroutine nvtxRangePop end interface nvtxRangePop - #endif - contains !> @brief Pushes a named NVTX range for GPU profiling, optionally with a color based on the given identifier. subroutine nvtxStartRange(name, id) - character(kind=c_char, len=*), intent(IN) :: name - integer, intent(IN), optional :: id - type(nvtxEventAttributes) :: event + character(kind=c_char, len=*), intent(in) :: name + integer, intent(in), optional :: id + type(nvtxEventAttributes) :: event #if defined(MFC_GPU) && defined(__PGI) - tempName = trim(name)//c_null_char + tempName = trim(name) // c_null_char if (.not. present(id)) then call nvtxRangePush(tempName) @@ -75,15 +68,12 @@ subroutine nvtxStartRange(name, id) event%message = c_loc(tempName) call nvtxRangePushEx(event) end if - #endif end subroutine nvtxStartRange - !> @brief Pops the current NVTX range to end the GPU profiling region. subroutine nvtxEndRange #if defined(MFC_GPU) && defined(__PGI) call nvtxRangePop #endif end subroutine nvtxEndRange - end module m_nvtx diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index ecd519e41c..57e15d73c4 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -7,7 +7,6 @@ !> @brief Phase transition relaxation solvers for liquid-vapor flows with cavitation and boiling module m_phase_change - #ifndef MFC_POST_PROCESS use m_derived_types !< Definitions of the derived types @@ -24,20 +23,17 @@ module m_phase_change implicit none - private; - public :: s_initialize_phasechange_module, & - s_relaxation_solver, & - s_infinite_relaxation_k, & - s_finalize_relaxation_solver_module + private; + public :: s_initialize_phasechange_module, s_relaxation_solver, s_infinite_relaxation_k, s_finalize_relaxation_solver_module !> @name Parameters for the first order transition phase change !> @{ - integer, parameter :: max_iter = 1e8_wp !< max # of iterations + integer, parameter :: max_iter = 1e8_wp !< max # of iterations real(wp), parameter :: pCr = 4.94e7_wp !< Critical water pressure real(wp), parameter :: TCr = 385.05_wp + 273.15_wp !< Critical water temperature real(wp), parameter :: mixM = 1.0e-8_wp !< threshold for 'mixture cell'. If Y < mixM, phase change does not happen - integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid - integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid + integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid + integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid !> @} !> @name Gibbs free energy phase change parameters @@ -45,49 +41,37 @@ module m_phase_change real(wp) :: A, B, C, D !> @} - $:GPU_DECLARE(create='[A,B,C,D]') - + $:GPU_DECLARE(create='[A, B, C, D]') contains - !> This subroutine should dispatch to the correct relaxation solver based - !! some parameter. It replaces the procedure pointer, which CCE - !! is breaking on. + !> This subroutine should dispatch to the correct relaxation solver based some parameter. It replaces the procedure pointer, + !! which CCE is breaking on. impure subroutine s_relaxation_solver(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf ! This is empty because in current master the procedure pointer ! was never assigned @:ASSERT(.false., "s_relaxation_solver called but it currently does nothing") end subroutine s_relaxation_solver - - !> The purpose of this subroutine is to initialize the phase change module - !! by setting the parameters needed for phase change and - !! selecting the phase change module that will be used - !! (pT- or pTg-equilibrium) + !> The purpose of this subroutine is to initialize the phase change module by setting the parameters needed for phase change and + !! selecting the phase change module that will be used (pT- or pTg-equilibrium) impure subroutine s_initialize_phasechange_module ! variables used in the calculation of the saturation curves for fluids 1 and 2 - A = (gs_min(lp)*cvs(lp) - gs_min(vp)*cvs(vp) & - + qvps(vp) - qvps(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) + A = (gs_min(lp)*cvs(lp) - gs_min(vp)*cvs(vp) + qvps(vp) - qvps(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) B = (qvs(lp) - qvs(vp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) - C = (gs_min(vp)*cvs(vp) - gs_min(lp)*cvs(lp)) & - /((gs_min(vp) - 1.0_wp)*cvs(vp)) - - D = ((gs_min(lp) - 1.0_wp)*cvs(lp)) & - /((gs_min(vp) - 1.0_wp)*cvs(vp)) + C = (gs_min(vp)*cvs(vp) - gs_min(lp)*cvs(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) + D = ((gs_min(lp) - 1.0_wp)*cvs(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) end subroutine s_initialize_phasechange_module - - !> This subroutine is created to activate either the pT- (N fluids) or the - !! pTg-equilibrium (2 fluids for g-equilibrium) - !! model, also considering mass depletion, depending on the incoming - !! state conditions. - !! @param q_cons_vf Cell-average conservative variables + !> This subroutine is created to activate either the pT- (N fluids) or the pTg-equilibrium (2 fluids for g-equilibrium) model, + !! also considering mass depletion, depending on the incoming state conditions. + !! @param q_cons_vf Cell-average conservative variables subroutine s_infinite_relaxation_k(q_cons_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid - real(wp) :: TS, TSOV, TSSL, TSatOV, TSatSL !< equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor and subcooled liquid + real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid + real(wp) :: TS, TSOV, TSSL, TSatOV, & + & TSatSL !< equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor and subcooled liquid real(wp) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy real(wp) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses real(wp) :: TvF !< total volume fraction @@ -107,29 +91,27 @@ contains #ifdef _CRAYFTN #ifdef MFC_OpenACC ! CCE 19 IPA workaround: prevent bring_routine_resident SIGSEGV - !DIR$ NOINLINE s_infinite_pt_relaxation_k - !DIR$ NOINLINE s_infinite_ptg_relaxation_k - !DIR$ NOINLINE s_correct_partial_densities - !DIR$ NOINLINE s_TSat + ! DIR$ NOINLINE s_infinite_pt_relaxation_k + ! DIR$ NOINLINE s_infinite_ptg_relaxation_k + ! DIR$ NOINLINE s_correct_partial_densities + ! DIR$ NOINLINE s_TSat #endif #endif ! starting equilibrium solver - $:GPU_PARALLEL_LOOP(collapse=3, private='[i,j,k,l,p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok,pS, pSOV, pSSL, TS, TSOV, TSatOV, TSatSL, TSSL, rhoe, dynE, rhos, rho, rM, m1, m2, MCT, TvF]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok, pS, pSOV, pSSL, TS, & + & TSOV, TSatOV, TSatSL, TSSL, rhoe, dynE, rhos, rho, rM, m1, m2, MCT, TvF]') do j = 0, m do k = 0, n do l = 0, p - rho = 0.0_wp; TvF = 0.0_wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - ! Mixture density rho = rho + q_cons_vf(i + contxb - 1)%sf(j, k, l) ! Total Volume Fraction TvF = TvF + q_cons_vf(i + advxb - 1)%sf(j, k, l) - end do ! calculating the total reacting mass for the phase change process. By hypothesis, this should not change @@ -149,9 +131,7 @@ contains dynE = 0.0_wp $:GPU_LOOP(parallelism='[seq]') do i = momxb, momxe - dynE = dynE + 5.0e-1_wp*q_cons_vf(i)%sf(j, k, l)**2/rho - end do ! calculating the total energy that MUST be preserved throughout the pT- and pTg-relaxation procedures @@ -167,10 +147,9 @@ contains ! NOTE that NOTHING else needs to be updated OTHER than the individual partial densities ! given the outputs from the pT- and pTg-equilibrium solvers are just p and one of the partial masses ! (pTg- case) - if ((relax_model == 6) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) > mixM*rM) & - .and. (q_cons_vf(vp + contxb - 1)%sf(j, k, l) > mixM*rM)) & - .and. (pS < pCr) .and. (TS < TCr)) then - + if ((relax_model == 6) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, & + & l) > mixM*rM) .and. (q_cons_vf(vp + contxb - 1)%sf(j, k, & + & l) > mixM*rM)) .and. (pS < pCr) .and. (TS < TCr)) then ! Checking if phase change is needed, by checking whether the final solution is either subcoooled ! liquid or overheated vapor. @@ -202,7 +181,6 @@ contains ! checking the conditions for overheated vapor and subcooled liquide if (TSOV > TSatOV) then - ! Assigning pressure pS = pSOV @@ -214,9 +192,7 @@ contains ! correcting the vapor partial density q_cons_vf(vp + contxb - 1)%sf(j, k, l) = (1.0_wp - mixM)*rM - - elseif (TSSL < TSatSL) then - + else if (TSSL < TSatSL) then ! Assigning pressure pS = pSSL @@ -228,7 +204,6 @@ contains ! correcting the vapor partial density q_cons_vf(vp + contxb - 1)%sf(j, k, l) = mixM*rM - else ! returning partial pressures to what they were from the homogeneous solver @@ -240,9 +215,7 @@ contains ! calling the pTg-equilibrium solver call s_infinite_ptg_relaxation_k(j, k, l, pS, p_infpT, rhoe, q_cons_vf, TS) - end if - end if ! Calculations AFTER equilibrium @@ -250,31 +223,25 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids ! entropy - sk(i) = cvs(i)*log((TS**gs_min(i)) & - /((pS + ps_inf(i))**(gs_min(i) - 1.0_wp))) + qvps(i) + sk(i) = cvs(i)*log((TS**gs_min(i))/((pS + ps_inf(i))**(gs_min(i) - 1.0_wp))) + qvps(i) ! enthalpy - hk(i) = gs_min(i)*cvs(i)*TS & - + qvs(i) + hk(i) = gs_min(i)*cvs(i)*TS + qvs(i) ! Gibbs-free energy gk(i) = hk(i) - TS*sk(i) ! densities - rhok(i) = (pS + ps_inf(i)) & - /((gs_min(i) - 1)*cvs(i)*TS) + rhok(i) = (pS + ps_inf(i))/((gs_min(i) - 1)*cvs(i)*TS) ! internal energy - ek(i) = (pS + gs_min(i) & - *ps_inf(i))/(pS + ps_inf(i)) & - *cvs(i)*TS + qvs(i) + ek(i) = (pS + gs_min(i)*ps_inf(i))/(pS + ps_inf(i))*cvs(i)*TS + qvs(i) end do ! calculating volume fractions, internal energies, and total entropy rhos = 0.0_wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - ! volume fractions q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/rhok(i) @@ -285,40 +252,35 @@ contains ! Total entropy rhos = rhos + q_cons_vf(i + contxb - 1)%sf(j, k, l)*sk(i) - end do end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_infinite_relaxation_k - - !> This auxiliary subroutine is created to activate the pT-equilibrium for N fluids - !! @param j generic loop iterator for x direction - !! @param k generic loop iterator for y direction - !! @param l generic loop iterator for z direction - !! @param MFL flag that tells whether the fluid is gas (0), liquid (1), or a mixture (2) - !! @param pS equilibrium pressure at the interface - !! @param p_infpT stiffness for the participating fluids under pT-equilibrium - !! @param q_cons_vf Cell-average conservative variables - !! @param rhoe mixture energy - !! @param TS equilibrium temperature at the interface + !> This auxiliary subroutine is created to activate the pT-equilibrium for N fluids + !! @param j generic loop iterator for x direction + !! @param k generic loop iterator for y direction + !! @param l generic loop iterator for z direction + !! @param MFL flag that tells whether the fluid is gas (0), liquid (1), or a mixture (2) + !! @param pS equilibrium pressure at the interface + !! @param p_infpT stiffness for the participating fluids under pT-equilibrium + !! @param q_cons_vf Cell-average conservative variables + !! @param rhoe mixture energy + !! @param TS equilibrium temperature at the interface subroutine s_infinite_pt_relaxation_k(j, k, l, MFL, pS, p_infpT, q_cons_vf, rhoe, TS) - $:GPU_ROUTINE(function_name='s_infinite_pt_relaxation_k', & - & parallelism='[seq]', cray_noinline=True) + $:GPU_ROUTINE(function_name='s_infinite_pt_relaxation_k', parallelism='[seq]', cray_noinline=True) ! initializing variables - integer, intent(in) :: j, k, l, MFL - real(wp), intent(out) :: pS - real(wp), dimension(1:), intent(out) :: p_infpT + integer, intent(in) :: j, k, l, MFL + real(wp), intent(out) :: pS + real(wp), dimension(1:), intent(out) :: p_infpT type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(wp), intent(in) :: rhoe - real(wp), intent(out) :: TS - real(wp) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver - real(wp) :: p_infpT_sum - - integer :: i, ns !< generic loop iterators + real(wp), intent(in) :: rhoe + real(wp), intent(out) :: TS + real(wp) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver + real(wp) :: p_infpT_sum + integer :: i, ns !< generic loop iterators ! auxiliary variables for the pT-equilibrium solver mCP = 0.0_wp; mQ = 0.0_wp; p_infpT_sum = 0._wp @@ -330,13 +292,11 @@ contains ! Performing tests before initializing the pT-equilibrium $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - ! sum of the total alpha*rho*cp of the system mCP = mCP + q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*gs_min(i) ! sum of the total alpha*rho*q of the system mQ = mQ + q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) - end do #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -350,9 +310,7 @@ contains ! Checking energy constraint if ((rhoe - mQ - minval(p_infpT)) < 0.0_wp) then - if ((MFL == 0) .or. (MFL == 1)) then - ! Assigning zero values for mass depletion cases ! pressure pS = 0.0_wp @@ -362,7 +320,6 @@ contains return end if - end if ! calculating initial estimate for pressure in the pT-relaxation procedure. I will also use this variable to @@ -377,7 +334,6 @@ contains ns = 0 ! change this relative error metric. 1.e4_wp is just arbitrary do while ((abs(pS - pO) > palpha_eps) .and. (abs((pS - pO)/pO) > palpha_eps/1.e4_wp) .or. (ns == 0)) - ! increasing counter ns = ns + 1 @@ -388,57 +344,50 @@ contains gpp = 0.0_wp; gp = 0.0_wp; hp = 0.0_wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids + gp = gp + (gs_min(i) - 1.0_wp)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*(rhoe + pS - mQ)/(mCP*(pS + p_infpT(i))) - gp = gp + (gs_min(i) - 1.0_wp)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i) & - *(rhoe + pS - mQ)/(mCP*(pS + p_infpT(i))) - - gpp = gpp + (gs_min(i) - 1.0_wp)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i) & - *(p_infpT(i) - rhoe + mQ)/(mCP*(pS + p_infpT(i))**2) - + gpp = gpp + (gs_min(i) - 1.0_wp)*q_cons_vf(i + contxb - 1)%sf(j, k, & + & l)*cvs(i)*(p_infpT(i) - rhoe + mQ)/(mCP*(pS + p_infpT(i))**2) end do hp = 1.0_wp/(rhoe + pS - mQ) + 1.0_wp/(pS + minval(p_infpT)) ! updating common pressure for the newton solver - pS = pO + ((1.0_wp - gp)/gpp)/(1.0_wp - (1.0_wp - gp + abs(1.0_wp - gp)) & - /(2.0_wp*gpp)*hp) + pS = pO + ((1.0_wp - gp)/gpp)/(1.0_wp - (1.0_wp - gp + abs(1.0_wp - gp))/(2.0_wp*gpp)*hp) end do ! common temperature TS = (rhoe + pS - mQ)/mCP - end subroutine s_infinite_pt_relaxation_k - - !> This auxiliary subroutine is created to activate the pTg-equilibrium for N fluids under pT - !! and 2 fluids under pTg-equilibrium. There is a final common p and T during relaxation - !! @param j generic loop iterator for x direction - !! @param k generic loop iterator for y direction - !! @param l generic loop iterator for z direction - !! @param pS equilibrium pressure at the interface - !! @param p_infpT stiffness for the participating fluids under pT-equilibrium - !! @param rhoe mixture energy - !! @param q_cons_vf Cell-average conservative variables - !! @param TS equilibrium temperature at the interface + !> This auxiliary subroutine is created to activate the pTg-equilibrium for N fluids under pT and 2 fluids under + !! pTg-equilibrium. There is a final common p and T during relaxation + !! @param j generic loop iterator for x direction + !! @param k generic loop iterator for y direction + !! @param l generic loop iterator for z direction + !! @param pS equilibrium pressure at the interface + !! @param p_infpT stiffness for the participating fluids under pT-equilibrium + !! @param rhoe mixture energy + !! @param q_cons_vf Cell-average conservative variables + !! @param TS equilibrium temperature at the interface subroutine s_infinite_ptg_relaxation_k(j, k, l, pS, p_infpT, rhoe, q_cons_vf, TS) - $:GPU_ROUTINE(function_name='s_infinite_ptg_relaxation_k', & - & parallelism='[seq]', cray_noinline=True) + $:GPU_ROUTINE(function_name='s_infinite_ptg_relaxation_k', parallelism='[seq]', cray_noinline=True) - integer, intent(in) :: j, k, l - real(wp), intent(inout) :: pS - real(wp), dimension(1:), intent(in) :: p_infpT - real(wp), intent(in) :: rhoe + integer, intent(in) :: j, k, l + real(wp), intent(inout) :: pS + real(wp), dimension(1:), intent(in) :: p_infpT + real(wp), intent(in) :: rhoe type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(wp), intent(inout) :: TS + real(wp), intent(inout) :: TS #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium #:else real(wp), dimension(num_fluids) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium #:endif real(wp), dimension(2, 2) :: Jac, InvJac, TJac !< matrices for the Newton Solver - real(wp), dimension(2) :: R2D, DeltamP !< residual and correction array - real(wp) :: Om ! underrelaxation factor - real(wp) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver - real(wp) :: ml, mT, dFdT, dTdm, dTdp + real(wp), dimension(2) :: R2D, DeltamP !< residual and correction array + real(wp) :: Om ! underrelaxation factor + real(wp) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver + real(wp) :: ml, mT, dFdT, dTdm, dTdp !< Generic loop iterators integer :: i, ns @@ -452,14 +401,10 @@ contains p_infpTg = p_infpT - if (((pS < 0.0_wp) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) & - + q_cons_vf(vp + contxb - 1)%sf(j, k, l)) > ((rhoe & - - gs_min(lp)*ps_inf(lp)/(gs_min(lp) - 1))/qvs(lp)))) .or. & - ((pS >= 0.0_wp) .and. (pS < 1.0e-1_wp))) then - + if (((pS < 0.0_wp) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, & + & l)) > ((rhoe - gs_min(lp)*ps_inf(lp)/(gs_min(lp) - 1))/qvs(lp)))) .or. ((pS >= 0.0_wp) .and. (pS < 1.0e-1_wp))) then ! improve this initial condition pS = 1.0e4_wp - end if ! Loop until the solution for F(X) is satisfied @@ -469,9 +414,8 @@ contains ! improve this initial condition R2D(1) = 0.0_wp; R2D(2) = 0.0_wp DeltamP(1) = 0.0_wp; DeltamP(2) = 0.0_wp - do while (((sqrt(R2D(1)**2 + R2D(2)**2) > ptgalpha_eps) & - .and. ((sqrt(R2D(1)**2 + R2D(2)**2)/rhoe) > (ptgalpha_eps/1.e6_wp))) & - .or. (ns == 0)) + do while (((sqrt(R2D(1)**2 + R2D(2)**2) > ptgalpha_eps) .and. ((sqrt(R2D(1)**2 + R2D(2)**2)/rhoe) > (ptgalpha_eps/1.e6_wp) & + & )) .or. (ns == 0)) ! Updating counter for the iterative procedure ns = ns + 1 @@ -482,10 +426,8 @@ contains ! the partial masses for all fluids, or on the equilibrium pressure $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - ! sum of the total alpha*rho*cp of the system - mCP = mCP + q_cons_vf(i + contxb - 1)%sf(j, k, l) & - *cvs(i)*gs_min(i) + mCP = mCP + q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*gs_min(i) ! sum of the total alpha*rho*q of the system mQ = mQ + q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) @@ -493,21 +435,15 @@ contains ! These auxiliary variables now need to be updated, as the partial densities now ! vary at every iteration if ((i /= lp) .and. (i /= vp)) then + mCVGP = mCVGP + q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*(gs_min(i) - 1)/(pS + ps_inf(i)) - mCVGP = mCVGP + q_cons_vf(i + contxb - 1)%sf(j, k, l) & - *cvs(i)*(gs_min(i) - 1)/(pS + ps_inf(i)) - - mCVGP2 = mCVGP2 + q_cons_vf(i + contxb - 1)%sf(j, k, l) & - *cvs(i)*(gs_min(i) - 1)/((pS + ps_inf(i))**2) + mCVGP2 = mCVGP2 + q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*(gs_min(i) - 1)/((pS + ps_inf(i))**2) mQD = mQD + q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) ! sum of the total alpha*rho*cp of the system - mCPD = mCPD + q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i) & - *gs_min(i) - + mCPD = mCPD + q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*gs_min(i) end if - end do ! calculating the (2D) Jacobian Matrix used in the solution of the pTg-quilibrium model @@ -516,27 +452,18 @@ contains ml = q_cons_vf(lp + contxb - 1)%sf(j, k, l) ! mass of the two participating fluids - mT = q_cons_vf(lp + contxb - 1)%sf(j, k, l) & - + q_cons_vf(vp + contxb - 1)%sf(j, k, l) + mT = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, l) - TS = 1/(mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) & - + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) & - + mCVGP) + TS = 1/(mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp) & + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) - dFdT = & - -(cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*log(TS) & - - (qvps(lp) - qvps(vp)) & - + cvs(lp)*(gs_min(lp) - 1)*log(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)*log(pS + ps_inf(vp)) + dFdT = -(cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*log(TS) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) - 1)*log(pS & + & + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pS + ps_inf(vp)) - dTdm = -(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)))*TS**2 + dTdm = -(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)))*TS**2 - dTdp = (mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))**2 & - + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp))**2 & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))**2) & - + mCVGP2)*TS**2 + dTdp = (mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))**2 + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp))**2 - cvs(vp) & + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))**2) + mCVGP2)*TS**2 ! F = (F1,F2) is the function whose roots we are looking for ! x = (m1, p) are the independent variables. m1 = mass of the first participant fluid, p = pressure @@ -546,32 +473,22 @@ contains Jac(1, 1) = dFdT*dTdm ! dF1dp - Jac(1, 2) = dFdT*dTdp + TS & - *(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) + Jac(1, 2) = dFdT*dTdp + TS*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) ! dF2dm - Jac(2, 1) = (qvs(vp) - qvs(lp) & - + (cvs(vp)*gs_min(vp) - cvs(lp)*gs_min(lp)) & - /(ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) & - + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + mCVGP) & - - (ml*(cvs(vp)*gs_min(vp) - cvs(lp)*gs_min(lp)) & - - mT*cvs(vp)*gs_min(vp) - mCPD) & - *(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) & - /((ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) & - + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + mCVGP)**2))/1 + Jac(2, & + & 1) = (qvs(vp) - qvs(lp) + (cvs(vp)*gs_min(vp) - cvs(lp)*gs_min(lp))/(ml*(cvs(lp)*(gs_min(lp) - 1)/(pS & + & + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) & + & + mCVGP) - (ml*(cvs(vp)*gs_min(vp) - cvs(lp)*gs_min(lp)) - mT*cvs(vp)*gs_min(vp) - mCPD)*(cvs(lp)*(gs_min(lp) & + & - 1)/(pS + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)))/((ml*(cvs(lp)*(gs_min(lp) - 1)/(pS & + & + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) & + & + mCVGP)**2))/1 ! dF2dp - Jac(2, 2) = (1 + (ml*(cvs(vp)*gs_min(vp) - cvs(lp)*gs_min(lp)) & - - mT*cvs(vp)*gs_min(vp) - mCPD) & - *(ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp))**2 & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))**2) & - + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))**2 + mCVGP2) & - /(ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) & - + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + mCVGP)**2)/1 + Jac(2, & + & 2) = (1 + (ml*(cvs(vp)*gs_min(vp) - cvs(lp)*gs_min(lp)) - mT*cvs(vp)*gs_min(vp) - mCPD)*(ml*(cvs(lp)*(gs_min(lp) & + & - 1)/(pS + ps_inf(lp))**2 - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))**2) + mT*cvs(vp)*(gs_min(vp) - 1)/(pS & + & + ps_inf(vp))**2 + mCVGP2)/(ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS & + & + ps_inf(vp))) + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + mCVGP)**2)/1 ! intermediate elements of J^{-1} InvJac(1, 1) = Jac(2, 2) @@ -609,68 +526,51 @@ contains ml = q_cons_vf(lp + contxb - 1)%sf(j, k, l) ! mass of the two participating fluids - mT = q_cons_vf(lp + contxb - 1)%sf(j, k, l) & - + q_cons_vf(vp + contxb - 1)%sf(j, k, l) + mT = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, l) - TS = 1/(mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) & - + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) & - + mCVGP) + TS = 1/(mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp) & + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) ! Gibbs Free Energy Equality condition (DG) - R2D(1) = TS*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp)) & - *(1 - log(TS)) - (qvps(lp) - qvps(vp)) & - + cvs(lp)*(gs_min(lp) - 1)*log(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)*log(pS + ps_inf(vp))) & - + qvs(lp) - qvs(vp) + R2D(1) = TS*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*(1 - log(TS)) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) & + & - 1)*log(pS + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pS + ps_inf(vp))) + qvs(lp) - qvs(vp) ! Constant Energy Process condition (DE) - R2D(2) = (rhoe + pS & - + ml*(qvs(vp) - qvs(lp)) - mT*qvs(vp) - mQD & - + (ml*(gs_min(vp)*cvs(vp) - gs_min(lp)*cvs(lp)) & - - mT*gs_min(vp)*cvs(vp) - mCPD) & - /(ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))) & - + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + mCVGP))/1 - + R2D(2) = (rhoe + pS + ml*(qvs(vp) - qvs(lp)) - mT*qvs(vp) - mQD + (ml*(gs_min(vp)*cvs(vp) - gs_min(lp)*cvs(lp)) & + & - mT*gs_min(vp)*cvs(vp) - mCPD)/(ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS & + & + ps_inf(vp))) + mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + mCVGP))/1 end do ! common temperature TS = (rhoe + pS - mQ)/mCP end subroutine s_infinite_ptg_relaxation_k - - !> This auxiliary subroutine corrects the partial densities of the REACTING fluids in case one of them is negative - !! but their sum is positive. Inert phases are not corrected at this moment - !! @param MCT partial density correction parameter - !! @param q_cons_vf Cell-average conservative variables - !! @param rM sum of the reacting masses - !! @param j generic loop iterator for x direction - !! @param k generic loop iterator for y direction - !! @param l generic loop iterator for z direction + !> This auxiliary subroutine corrects the partial densities of the REACTING fluids in case one of them is negative but their sum + !! is positive. Inert phases are not corrected at this moment + !! @param MCT partial density correction parameter + !! @param q_cons_vf Cell-average conservative variables + !! @param rM sum of the reacting masses + !! @param j generic loop iterator for x direction + !! @param k generic loop iterator for y direction + !! @param l generic loop iterator for z direction subroutine s_correct_partial_densities(MCT, q_cons_vf, rM, j, k, l) - $:GPU_ROUTINE(function_name='s_correct_partial_densities', & - & parallelism='[seq]', cray_noinline=True) + $:GPU_ROUTINE(function_name='s_correct_partial_densities', parallelism='[seq]', cray_noinline=True) !> @name variables for the correction of the reacting partial densities !> @{ - real(wp), intent(out) :: MCT + real(wp), intent(out) :: MCT type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(wp), intent(inout) :: rM - integer, intent(in) :: j, k, l + real(wp), intent(inout) :: rM + integer, intent(in) :: j, k, l !> @} if (rM < 0.0_wp) then - - if ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) >= -1.0_wp*mixM) .and. & - (q_cons_vf(vp + contxb - 1)%sf(j, k, l) >= -1.0_wp*mixM)) then - + if ((q_cons_vf(lp + contxb - 1)%sf(j, k, l) >= -1.0_wp*mixM) .and. (q_cons_vf(vp + contxb - 1)%sf(j, k, & + & l) >= -1.0_wp*mixM)) then q_cons_vf(lp + contxb - 1)%sf(j, k, l) = 0.0_wp q_cons_vf(vp + contxb - 1)%sf(j, k, l) = 0.0_wp rM = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, l) - end if - end if ! Defining the correction in terms of an absolute value might not be the best practice. @@ -679,43 +579,33 @@ contains ! correcting the partial densities of the reacting fluids. What to do for the nonreacting ones? if (q_cons_vf(lp + contxb - 1)%sf(j, k, l) < 0.0_wp) then - q_cons_vf(lp + contxb - 1)%sf(j, k, l) = MCT*rM q_cons_vf(vp + contxb - 1)%sf(j, k, l) = (1.0_wp - MCT)*rM - - elseif (q_cons_vf(vp + contxb - 1)%sf(j, k, l) < 0.0_wp) then - + else if (q_cons_vf(vp + contxb - 1)%sf(j, k, l) < 0.0_wp) then q_cons_vf(lp + contxb - 1)%sf(j, k, l) = (1.0_wp - MCT)*rM q_cons_vf(vp + contxb - 1)%sf(j, k, l) = MCT*rM - end if end subroutine s_correct_partial_densities - - !> This auxiliary subroutine finds the Saturation temperature for a given - !! saturation pressure through a newton solver - !! @param pSat Saturation Pressure - !! @param TSat Saturation Temperature - !! @param TSIn equilibrium Temperature + !> This auxiliary subroutine finds the Saturation temperature for a given saturation pressure through a newton solver + !! @param pSat Saturation Pressure + !! @param TSat Saturation Temperature + !! @param TSIn equilibrium Temperature elemental subroutine s_TSat(pSat, TSat, TSIn) - $:GPU_ROUTINE(function_name='s_TSat',parallelism='[seq]', & - & cray_noinline=True) + $:GPU_ROUTINE(function_name='s_TSat',parallelism='[seq]', cray_noinline=True) - real(wp), intent(in) :: pSat + real(wp), intent(in) :: pSat real(wp), intent(out) :: TSat - real(wp), intent(in) :: TSIn - - real(wp) :: dFdT, FT, Om !< auxiliary variables + real(wp), intent(in) :: TSIn + real(wp) :: dFdT, FT, Om !< auxiliary variables ! Generic loop iterators integer :: ns if ((f_approx_equal(pSat, 0.0_wp)) .and. (f_approx_equal(TSIn, 0.0_wp))) then - ! assigning Saturation temperature TSat = 0.0_wp - else ! calculating initial estimate for temperature in the TSat procedure. I will also use this variable to @@ -738,33 +628,22 @@ contains ns = ns + 1 ! calculating residual - FT = TSat*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp)) & - *(1 - log(TSat)) - (qvps(lp) - qvps(vp)) & - + cvs(lp)*(gs_min(lp) - 1)*log(pSat + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp))) & - + qvs(lp) - qvs(vp) + FT = TSat*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*(1 - log(TSat)) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) & + & - 1)*log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp))) + qvs(lp) - qvs(vp) ! calculating the jacobian - dFdT = & - -(cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*log(TSat) & - - (qvps(lp) - qvps(vp)) & - + cvs(lp)*(gs_min(lp) - 1)*log(pSat + ps_inf(lp)) & - - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp)) + dFdT = -(cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*log(TSat) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) - 1) & + & *log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp)) ! updating saturation temperature TSat = TSat - Om*FT/dFdT if (abs(FT) <= ptgalpha_eps) exit end do - end if - end subroutine s_TSat - - !> This subroutine finalizes the phase change module + !> This subroutine finalizes the phase change module impure subroutine s_finalize_relaxation_solver_module end subroutine s_finalize_relaxation_solver_module - #endif - end module m_phase_change diff --git a/src/common/m_precision_select.f90 b/src/common/m_precision_select.f90 index 9874ccd87f..51809bb069 100644 --- a/src/common/m_precision_select.f90 +++ b/src/common/m_precision_select.f90 @@ -3,7 +3,6 @@ !> @brief Working-precision kind selection (half/single/double) and corresponding MPI datatype parameters module m_precision_select - ! use, intrinsic :: iso_c_binding #ifdef MFC_MPI @@ -16,14 +15,13 @@ module m_precision_select integer, parameter :: half_precision = 2 ! selected_real_kind(3, 4) integer, parameter :: single_precision = selected_real_kind(6, 37) integer, parameter :: double_precision = selected_real_kind(15, 307) - integer, parameter :: hp = half_precision integer, parameter :: sp = single_precision integer, parameter :: dp = double_precision ! Set the working precision (wp) to single or double #ifdef MFC_SINGLE_PRECISION - integer, parameter :: wp = single_precision ! Change to single_precision if needed + integer, parameter :: wp = single_precision ! Change to single_precision if needed #else integer, parameter :: wp = double_precision #endif @@ -43,10 +41,9 @@ module m_precision_select ! MPI types per element. IE Real(kind=2) <=> 2 MPI_BYTE integer, parameter :: mpi_io_type = merge(2, 1, stp == half_precision) #else - integer, parameter :: mpi_p = -100 ! Default value when MPI is not used + integer, parameter :: mpi_p = -100 ! Default value when MPI is not used integer, parameter :: mpi_2p = -100 integer, parameter :: mpi_io_p = -100 integer, parameter :: mpi_io_type = -100 #endif - end module m_precision_select diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 632c8df1b0..f36c4262b6 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -7,7 +7,6 @@ !> @brief Conservative-to-primitive variable conversion, mixture property evaluation, and pressure computation module m_variables_conversion - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -18,13 +17,12 @@ module m_variables_conversion use m_helper - use m_thermochem, only: & - num_species, get_temperature, get_pressure, gas_constant, & - get_mixture_molecular_weight, get_mixture_energy_mass + use m_thermochem, only: num_species, get_temperature, get_pressure, gas_constant, get_mixture_molecular_weight, & + & get_mixture_energy_mass implicit none - private; + private; public :: s_initialize_variables_conversion_module, & s_initialize_pb, & s_initialize_mv, & @@ -38,68 +36,59 @@ module m_variables_conversion s_compute_pressure, & s_compute_species_fraction, & #ifndef MFC_PRE_PROCESS - s_compute_speed_of_sound, & + s_compute_speed_of_sound, & s_compute_fast_magnetosonic_speed, & #endif - s_finalize_variables_conversion_module + s_finalize_variables_conversion_module !! In simulation, gammas, pi_infs, and qvs are already declared in m_global_variables #ifndef MFC_SIMULATION real(wp), allocatable, public, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps - $:GPU_DECLARE(create='[gammas,gs_min,pi_infs,ps_inf,cvs,qvs,qvps]') + $:GPU_DECLARE(create='[gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps]') #endif - real(wp), allocatable, dimension(:) :: Gs_vc - integer, allocatable, dimension(:) :: bubrs_vc - real(wp), allocatable, dimension(:, :) :: Res_vc - $:GPU_DECLARE(create='[bubrs_vc,Gs_vc,Res_vc]') + real(wp), allocatable, dimension(:) :: Gs_vc + integer, allocatable, dimension(:) :: bubrs_vc + real(wp), allocatable, dimension(:,:) :: Res_vc + $:GPU_DECLARE(create='[bubrs_vc, Gs_vc, Res_vc]') integer :: is1b, is2b, is3b, is1e, is2e, is3e - $:GPU_DECLARE(create='[is1b,is2b,is3b,is1e,is2e,is3e]') - - real(wp), allocatable, dimension(:, :, :), public :: rho_sf !< Scalar density function - real(wp), allocatable, dimension(:, :, :), public :: gamma_sf !< Scalar sp. heat ratio function - real(wp), allocatable, dimension(:, :, :), public :: pi_inf_sf !< Scalar liquid stiffness function - real(wp), allocatable, dimension(:, :, :), public :: qv_sf !< Scalar liquid energy reference function + $:GPU_DECLARE(create='[is1b, is2b, is3b, is1e, is2e, is3e]') + real(wp), allocatable, dimension(:,:,:), public :: rho_sf !< Scalar density function + real(wp), allocatable, dimension(:,:,:), public :: gamma_sf !< Scalar sp. heat ratio function + real(wp), allocatable, dimension(:,:,:), public :: pi_inf_sf !< Scalar liquid stiffness function + real(wp), allocatable, dimension(:,:,:), public :: qv_sf !< Scalar liquid energy reference function contains - !> Dispatch to the s_convert_mixture_to_mixture_variables - !! and s_convert_species_to_mixture_variables subroutines. - !! Replaces a procedure pointer. - !! @param q_vf Conservative or primitive variables - !! @param i First-coordinate cell index - !! @param j Second-coordinate cell index - !! @param k Third-coordinate cell index - !! @param rho Density - !! @param gamma Specific heat ratio function - !! @param pi_inf Liquid stiffness function - !! @param qv Fluid reference energy - !! @param Re_K Reynolds number (optional) - !! @param G_K Shear modulus (optional) - !! @param G Shear moduli of the fluids (optional) - subroutine s_convert_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv, Re_K, G_K, G) - - type(scalar_field), dimension(sys_size), intent(in) :: q_vf - integer, intent(in) :: i, j, k - real(wp), intent(out), target :: rho, gamma, pi_inf, qv - real(wp), optional, dimension(2), intent(out) :: Re_K - real(wp), optional, intent(out) :: G_K + !> Dispatch to the s_convert_mixture_to_mixture_variables and s_convert_species_to_mixture_variables subroutines. Replaces a + !! procedure pointer. + !! @param q_vf Conservative or primitive variables + !! @param i First-coordinate cell index + !! @param j Second-coordinate cell index + !! @param k Third-coordinate cell index + !! @param rho Density + !! @param gamma Specific heat ratio function + !! @param pi_inf Liquid stiffness function + !! @param qv Fluid reference energy + !! @param Re_K Reynolds number (optional) + !! @param G_K Shear modulus (optional) + !! @param G Shear moduli of the fluids (optional) + subroutine s_convert_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv, Re_K, G_K, G) + type(scalar_field), dimension(sys_size), intent(in) :: q_vf + integer, intent(in) :: i, j, k + real(wp), intent(out), target :: rho, gamma, pi_inf, qv + real(wp), optional, dimension(2), intent(out) :: Re_K + real(wp), optional, intent(out) :: G_K real(wp), optional, dimension(num_fluids), intent(in) :: G - if (model_eqns == 1) then ! Gamma/pi_inf model - call s_convert_mixture_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv) - - else ! Volume fraction model - call s_convert_species_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv, Re_K, G_K, G) + if (model_eqns == 1) then ! Gamma/pi_inf model + call s_convert_mixture_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv) + else ! Volume fraction model + call s_convert_species_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv, Re_K, G_K, G) end if - end subroutine s_convert_to_mixture_variables - - !> This procedure conditionally calculates the appropriate pressure + !> This procedure conditionally calculates the appropriate pressure !! @param energy Energy !! @param alf Void Fraction !! @param dyn_p Dynamic Pressure @@ -115,25 +104,23 @@ contains !! @param G Shear modulus (optional) !! @param pres_mag Magnetic pressure (optional) subroutine s_compute_pressure(energy, alf, dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, stress, mom, G, pres_mag) - $:GPU_ROUTINE(function_name='s_compute_pressure',parallelism='[seq]', & - & cray_noinline=True) - - real(stp), intent(in) :: energy, alf - real(wp), intent(in) :: dyn_p - real(wp), intent(in) :: pi_inf, gamma, rho, qv - real(wp), intent(out) :: pres - real(wp), intent(inout) :: T + $:GPU_ROUTINE(function_name='s_compute_pressure',parallelism='[seq]', cray_noinline=True) + + real(stp), intent(in) :: energy, alf + real(wp), intent(in) :: dyn_p + real(wp), intent(in) :: pi_inf, gamma, rho, qv + real(wp), intent(out) :: pres + real(wp), intent(inout) :: T real(stp), intent(in), optional :: stress, mom - real(wp), intent(in), optional :: G, pres_mag + real(wp), intent(in), optional :: G, pres_mag ! Chemistry real(wp), dimension(1:num_species), intent(in) :: rhoYks - real(wp), dimension(1:num_species) :: Y_rs - real(wp) :: E_e - real(wp) :: e_Per_Kg, Pdyn_Per_Kg - real(wp) :: T_guess - - integer :: s !< Generic loop iterator + real(wp), dimension(1:num_species) :: Y_rs + real(wp) :: E_e + real(wp) :: e_Per_Kg, Pdyn_Per_Kg + real(wp) :: T_guess + integer :: s !< Generic loop iterator #:if not chemistry ! Depending on model_eqns and bubbles_euler, the appropriate procedure @@ -141,15 +128,12 @@ contains if (mhd) then pres = (energy - dyn_p - pi_inf - qv - pres_mag)/gamma - elseif ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then + else if ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then pres = (energy - dyn_p - pi_inf - qv)/gamma else if ((model_eqns /= 4) .and. bubbles_euler) then pres = ((energy - dyn_p)/(1._wp - alf) - pi_inf - qv)/gamma else - pres = (pref + pi_inf)* & - (energy/ & - (rhoref*(1 - alf)) & - )**(1/gamma + 1) - pi_inf + pres = (pref + pi_inf)*(energy/(rhoref*(1 - alf)))**(1/gamma + 1) - pi_inf end if if (hypoelasticity .and. present(G)) then @@ -165,14 +149,8 @@ contains end if end do - pres = ( & - energy - & - 0.5_wp*(mom**2._wp)/rho - & - pi_inf - qv - E_e & - )/gamma - + pres = (energy - 0.5_wp*(mom**2._wp)/rho - pi_inf - qv - E_e)/gamma end if - #:else Y_rs(:) = rhoYks(:)/rho @@ -183,16 +161,10 @@ contains call get_temperature(e_Per_Kg - Pdyn_Per_Kg, T_guess, Y_rs, .true., T) call get_pressure(rho, T, Y_rs, pres) - #:endif - end subroutine s_compute_pressure - - !> This subroutine is designed for the gamma/pi_inf model - !! and provided a set of either conservative or primitive - !! variables, transfers the density, specific heat ratio - !! function and the liquid stiffness function from q_vf to - !! rho, gamma and pi_inf. + !> This subroutine is designed for the gamma/pi_inf model and provided a set of either conservative or primitive variables, + !! transfers the density, specific heat ratio function and the liquid stiffness function from q_vf to rho, gamma and pi_inf. !! @param q_vf conservative or primitive variables !! @param i cell index to transfer mixture variables !! @param j cell index to transfer mixture variables @@ -201,16 +173,13 @@ contains !! @param gamma specific heat ratio function !! @param pi_inf liquid stiffness !! @param qv fluid reference energy - subroutine s_convert_mixture_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv) - + subroutine s_convert_mixture_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv) type(scalar_field), dimension(sys_size), intent(in) :: q_vf - integer, intent(in) :: i, j, k - - real(wp), intent(out), target :: rho - real(wp), intent(out), target :: gamma - real(wp), intent(out), target :: pi_inf - real(wp), intent(out), target :: qv + integer, intent(in) :: i, j, k + real(wp), intent(out), target :: rho + real(wp), intent(out), target :: gamma + real(wp), intent(out), target :: pi_inf + real(wp), intent(out), target :: qv ! Transferring the density, the specific heat ratio function and the ! liquid stiffness function, respectively @@ -226,14 +195,10 @@ contains pi_inf_sf(i, j, k) = pi_inf qv_sf(i, j, k) = qv #endif - end subroutine s_convert_mixture_to_mixture_variables - - !> This subroutine is designed for the volume fraction model - !! and provided a set of either conservative or primitive - !! variables, computes the density, the specific heat ratio - !! function and the liquid stiffness function from q_vf and - !! stores the results into rho, gamma and pi_inf. + !> This subroutine is designed for the volume fraction model and provided a set of either conservative or primitive variables, + !! computes the density, the specific heat ratio function and the liquid stiffness function from q_vf and stores the results + !! into rho, gamma and pi_inf. !! @param q_vf primitive variables !! @param k Cell index !! @param l Cell index @@ -245,24 +210,18 @@ contains !! @param Re_K Reynolds number (optional) !! @param G_K Shear modulus (optional) !! @param G Shear moduli of the fluids (optional) - subroutine s_convert_species_to_mixture_variables(q_vf, k, l, r, rho, & - gamma, pi_inf, qv, Re_K, G_K, G) - - type(scalar_field), dimension(sys_size), intent(in) :: q_vf - - integer, intent(in) :: k, l, r - - real(wp), intent(out), target :: rho - real(wp), intent(out), target :: gamma - real(wp), intent(out), target :: pi_inf - real(wp), intent(out), target :: qv - - real(wp), optional, dimension(2), intent(out) :: Re_K - real(wp), optional, intent(out) :: G_K - real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K !< + subroutine s_convert_species_to_mixture_variables(q_vf, k, l, r, rho, gamma, pi_inf, qv, Re_K, G_K, G) + type(scalar_field), dimension(sys_size), intent(in) :: q_vf + integer, intent(in) :: k, l, r + real(wp), intent(out), target :: rho + real(wp), intent(out), target :: gamma + real(wp), intent(out), target :: pi_inf + real(wp), intent(out), target :: qv + real(wp), optional, dimension(2), intent(out) :: Re_K + real(wp), optional, intent(out) :: G_K + real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K !< real(wp), optional, dimension(num_fluids), intent(in) :: G - - integer :: i, j !< Generic loop iterator + integer :: i, j !< Generic loop iterator ! Computing the density, the specific heat ratio function and the ! liquid stiffness function, respectively @@ -293,8 +252,7 @@ contains Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0._wp do j = 1, Re_size(i) - Re_K(i) = alpha_K(Re_idx(i, j))/fluid_pp(Re_idx(i, j))%Re(i) & - + Re_K(i) + Re_K(i) = alpha_K(Re_idx(i, j))/fluid_pp(Re_idx(i, j))%Re(i) + Re_K(i) end do Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) @@ -317,30 +275,24 @@ contains pi_inf_sf(k, l, r) = pi_inf qv_sf(k, l, r) = qv #endif - end subroutine s_convert_species_to_mixture_variables - - !> @brief GPU-accelerated conversion of species volume fractions and partial densities to mixture density, gamma, pi_inf, and qv. - subroutine s_convert_species_to_mixture_variables_acc(rho_K, & - gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, & - G_K, G) - $:GPU_ROUTINE(function_name='s_convert_species_to_mixture_variables_acc', & - & parallelism='[seq]', cray_noinline=True) + !> @brief GPU-accelerated conversion of species volume fractions and partial densities to mixture density, gamma, pi_inf, and + !! qv. + subroutine s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K, G_K, G) + $:GPU_ROUTINE(function_name='s_convert_species_to_mixture_variables_acc', parallelism='[seq]', cray_noinline=True) real(wp), intent(out) :: rho_K, gamma_K, pi_inf_K, qv_K #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3), intent(inout) :: alpha_rho_K, alpha_K !< + real(wp), dimension(3), intent(inout) :: alpha_rho_K, alpha_K !< real(wp), optional, dimension(3), intent(in) :: G #:else - real(wp), dimension(num_fluids), intent(inout) :: alpha_rho_K, alpha_K !< + real(wp), dimension(num_fluids), intent(inout) :: alpha_rho_K, alpha_K !< real(wp), optional, dimension(num_fluids), intent(in) :: G #:endif real(wp), dimension(2), intent(out) :: Re_K - real(wp), optional, intent(out) :: G_K - real(wp) :: alpha_K_sum - - integer :: i, j !< Generic loop iterators + real(wp), optional, intent(out) :: G_K + real(wp) :: alpha_K_sum + integer :: i, j !< Generic loop iterators #ifdef MFC_SIMULATION ! Constraining the partial densities and the volume fractions within @@ -374,8 +326,8 @@ contains if (present(G_K)) then G_K = 0._wp do i = 1, num_fluids - !TODO: change to use Gs_vc directly here? - !TODO: Make this changes as well for GPUs + ! TODO: change to use Gs_vc directly here? + ! TODO: Make this changes as well for GPUs G_K = G_K + alpha_K(i)*G(i) end do G_K = max(0._wp, G_K) @@ -388,25 +340,20 @@ contains if (Re_size(i) > 0) Re_K(i) = 0._wp do j = 1, Re_size(i) - Re_K(i) = alpha_K(Re_idx(i, j))/Res_vc(i, j) & - + Re_K(i) + Re_K(i) = alpha_K(Re_idx(i, j))/Res_vc(i, j) + Re_K(i) end do Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) end do end if #endif - end subroutine s_convert_species_to_mixture_variables_acc - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_variables_conversion_module - integer :: i, j - $:GPU_ENTER_DATA(copyin='[is1b,is1e,is2b,is2e,is3b,is3e]') + $:GPU_ENTER_DATA(copyin='[is1b, is1e, is2b, is2e, is3b, is3e]') @:ALLOCATE(gammas (1:num_fluids)) @:ALLOCATE(gs_min (1:num_fluids)) @@ -427,7 +374,7 @@ contains qvs(i) = fluid_pp(i)%qv qvps(i) = fluid_pp(i)%qvp end do - $:GPU_UPDATE(device='[gammas,gs_min,pi_infs,ps_inf,cvs,qvs,qvps,Gs_vc]') + $:GPU_UPDATE(device='[gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs_vc]') #ifdef MFC_SIMULATION @@ -439,7 +386,7 @@ contains end do end do - $:GPU_UPDATE(device='[Res_vc,Re_idx,Re_size]') + $:GPU_UPDATE(device='[Res_vc, Re_idx, Re_size]') end if #endif @@ -457,75 +404,42 @@ contains ! Simulation is at least 2D if (n > 0) then - ! Simulation is 3D if (p > 0) then - - allocate (rho_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) - allocate (gamma_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) - allocate (pi_inf_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) - allocate (qv_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) + allocate (rho_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, -buff_size:p + buff_size)) + allocate (gamma_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, -buff_size:p + buff_size)) + allocate (pi_inf_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, -buff_size:p + buff_size)) + allocate (qv_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, -buff_size:p + buff_size)) ! Simulation is 2D else - allocate (rho_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - 0:0)) - allocate (gamma_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - 0:0)) - allocate (pi_inf_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - 0:0)) - allocate (qv_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - 0:0)) + allocate (rho_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) + allocate (gamma_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) + allocate (pi_inf_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) + allocate (qv_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) end if ! Simulation is 1D else - allocate (rho_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) - allocate (gamma_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) - allocate (pi_inf_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) - allocate (qv_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) - + allocate (rho_sf(-buff_size:m + buff_size, 0:0, 0:0)) + allocate (gamma_sf(-buff_size:m + buff_size, 0:0, 0:0)) + allocate (pi_inf_sf(-buff_size:m + buff_size, 0:0, 0:0)) + allocate (qv_sf(-buff_size:m + buff_size, 0:0, 0:0)) end if #endif - end subroutine s_initialize_variables_conversion_module - !> @brief Initializes bubble mass-vapor values at quadrature nodes from the conserved moment statistics. subroutine s_initialize_mv(qK_cons_vf, mv) - - type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: mv - - integer :: i, j, k, l - real(wp) :: mu, sig, nbub_sc + integer :: i, j, k, l + real(wp) :: mu, sig, nbub_sc do l = idwint(3)%beg, idwint(3)%end do k = idwint(2)%beg, idwint(2)%end do j = idwint(1)%beg, idwint(1)%end - nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) $:GPU_LOOP(parallelism='[seq]') @@ -538,27 +452,21 @@ contains mv(j, k, l, 3, i) = (mass_v0(i))*(mu + sig)**(3._wp)/(R0(i)**(3._wp)) mv(j, k, l, 4, i) = (mass_v0(i))*(mu + sig)**(3._wp)/(R0(i)**(3._wp)) end do - end do end do end do - end subroutine s_initialize_mv - !> @brief Initializes bubble internal pressures at quadrature nodes using isothermal relations from the Preston model. subroutine s_initialize_pb(qK_cons_vf, mv, pb) - type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - - real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(in) :: mv + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf + real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(in) :: mv real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: pb - - integer :: i, j, k, l - real(wp) :: mu, sig, nbub_sc + integer :: i, j, k, l + real(wp) :: mu, sig, nbub_sc do l = idwint(3)%beg, idwint(3)%end do k = idwint(2)%beg, idwint(2)%end do j = idwint(1)%beg, idwint(1)%end - nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) $:GPU_LOOP(parallelism='[seq]') @@ -566,67 +474,59 @@ contains mu = qK_cons_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc sig = (qK_cons_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - mu**2)**0.5_wp - !PRESTON (ISOTHERMAL) - pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 1, i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) - pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 2, i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) - pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 3, i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) - pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 4, i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + ! PRESTON (ISOTHERMAL) + pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 1, & + & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 2, & + & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 3, & + & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 4, & + & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) end do end do end do end do - end subroutine s_initialize_pb - - !> The following procedure handles the conversion between - !! the conservative variables and the primitive variables. + !> The following procedure handles the conversion between the conservative variables and the primitive variables. !! @param qK_cons_vf Conservative variables !! @param q_T_sf Temperature scalar field !! @param qK_prim_vf Primitive variables !! @param ibounds Index bounds in each coordinate direction - subroutine s_convert_conservative_to_primitive_variables(qK_cons_vf, & - q_T_sf, & - qK_prim_vf, & - ibounds) - - type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - type(scalar_field), intent(inout) :: q_T_sf + subroutine s_convert_conservative_to_primitive_variables(qK_cons_vf, q_T_sf, qK_prim_vf, ibounds) + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf + type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(inout) :: qK_prim_vf - type(int_bounds_info), dimension(1:3), intent(in) :: ibounds + type(int_bounds_info), dimension(1:3), intent(in) :: ibounds #:if USING_AMD and not MFC_CASE_OPTIMIZATION real(wp), dimension(3) :: alpha_K, alpha_rho_K real(wp), dimension(3) :: nRtmp - real(wp) :: rhoYks(1:10) + real(wp) :: rhoYks(1:10) #:else real(wp), dimension(num_fluids) :: alpha_K, alpha_rho_K - real(wp), dimension(nb) :: nRtmp - real(wp) :: rhoYks(1:num_species) + real(wp), dimension(nb) :: nRtmp + real(wp) :: rhoYks(1:num_species) #:endif real(wp), dimension(2) :: Re_K - real(wp) :: rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K - - real(wp) :: vftmp, nbub_sc - - real(wp) :: G_K - - real(wp) :: pres - - integer :: i, j, k, l !< Generic loop iterators - - real(wp) :: T - real(wp) :: pres_mag - - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: B2 ! Magnetic field magnitude squared - real(wp) :: B(3) ! Magnetic field components - real(wp) :: m2 ! Relativistic momentum magnitude squared - real(wp) :: S ! Dot product of the magnetic field and the relativistic momentum - real(wp) :: W, dW ! W := rho*v*Ga**2; f = f(W) in Newton-Raphson - real(wp) :: E, D ! Prim/Cons variables within Newton-Raphson iteration - real(wp) :: f, dGa_dW, dp_dW, df_dW ! Functions within Newton-Raphson iteration - integer :: iter ! Newton-Raphson iteration counter - - $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_K, alpha_rho_K, Re_K, nRtmp, rho_K, gamma_K, pi_inf_K,qv_K, dyn_pres_K, rhoYks, B, pres, vftmp, nbub_sc, G_K, T, pres_mag, Ga, B2, m2, S, W, dW, E, D, f, dGa_dW, dp_dW, df_dW, iter ]') + real(wp) :: rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K + real(wp) :: vftmp, nbub_sc + real(wp) :: G_K + real(wp) :: pres + integer :: i, j, k, l !< Generic loop iterators + real(wp) :: T + real(wp) :: pres_mag + real(wp) :: Ga ! Lorentz factor (gamma in relativity) + real(wp) :: B2 ! Magnetic field magnitude squared + real(wp) :: B(3) ! Magnetic field components + real(wp) :: m2 ! Relativistic momentum magnitude squared + real(wp) :: S ! Dot product of the magnetic field and the relativistic momentum + real(wp) :: W, dW ! W := rho*v*Ga**2; f = f(W) in Newton-Raphson + real(wp) :: E, D ! Prim/Cons variables within Newton-Raphson iteration + real(wp) :: f, dGa_dW, dp_dW, df_dW ! Functions within Newton-Raphson iteration + integer :: iter ! Newton-Raphson iteration counter + + $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_K, alpha_rho_K, Re_K, nRtmp, rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K, & + & rhoYks, B, pres, vftmp, nbub_sc, G_K, T, pres_mag, Ga, B2, m2, S, W, dW, E, D, f, dGa_dW, dp_dW, df_dW, iter]') do l = ibounds(3)%beg, ibounds(3)%end do k = ibounds(2)%beg, ibounds(2)%end do j = ibounds(1)%beg, ibounds(1)%end @@ -638,20 +538,19 @@ contains #ifdef MFC_SIMULATION ! If in simulation, use acc mixture subroutines if (elasticity) then - call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, & - alpha_rho_K, Re_K, G_K, Gs_vc) + call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & + & Re_K, G_K, Gs_vc) else - call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K) + call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & + & Re_K) end if #else ! If pre-processing, use non acc mixture subroutines if (elasticity) then - call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, & - rho_K, gamma_K, pi_inf_K, qv_K, Re_K, G_K, fluid_pp(:)%G) + call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, rho_K, gamma_K, pi_inf_K, qv_K, Re_K, G_K, & + & fluid_pp(:)%G) else - call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, & - rho_K, gamma_K, pi_inf_K, qv_K) + call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, rho_K, gamma_K, pi_inf_K, qv_K) end if #endif end if @@ -697,7 +596,7 @@ contains f = W - pres + (1 - 1/(2*Ga**2))*B2 - S**2/(2*W**2) - E - D ! The first equation below corrects a typo in (Mignone & Bodo, 2006) - ! m2*W**2 → 2*m2*W**2, which would cancel with the 2* in other terms + ! m2*W**2 -> 2*m2*W**2, which would cancel with the 2* in other terms ! This corrected version is not used as the second equation empirically converges faster. ! First equation is kept for further investigation. ! dGa_dW = -Ga**3 * ( S**2*(3*W**2+3*W*B2+B2**2) + m2*W**2 ) / (W**3 * (W+B2)**3) ! first (corrected) @@ -760,13 +659,10 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, momxe if (model_eqns /= 4) then - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) & - /rho_K - dyn_pres_K = dyn_pres_K + 5.e-1_wp*qK_cons_vf(i)%sf(j, k, l) & - *qK_prim_vf(i)%sf(j, k, l) + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/rho_K + dyn_pres_K = dyn_pres_K + 5.e-1_wp*qK_cons_vf(i)%sf(j, k, l)*qK_prim_vf(i)%sf(j, k, l) else - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) & - /qK_cons_vf(1)%sf(j, k, l) + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/qK_cons_vf(1)%sf(j, k, l) end if end do @@ -781,18 +677,18 @@ contains if (mhd) then if (n == 0) then - pres_mag = 0.5_wp*(Bx0**2 + qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, l)**2) + pres_mag = 0.5_wp*(Bx0**2 + qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, & + & l)**2) else - pres_mag = 0.5_wp*(qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 2)%sf(j, k, l)**2) + pres_mag = 0.5_wp*(qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, & + & l)**2 + qK_cons_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if else pres_mag = 0._wp end if - call s_compute_pressure(qK_cons_vf(E_idx)%sf(j, k, l), & - qK_cons_vf(alf_idx)%sf(j, k, l), & - dyn_pres_K, pi_inf_K, gamma_K, rho_K, & - qv_K, rhoYks, pres, T, pres_mag=pres_mag) + call s_compute_pressure(qK_cons_vf(E_idx)%sf(j, k, l), qK_cons_vf(alf_idx)%sf(j, k, l), dyn_pres_K, pi_inf_K, & + & gamma_K, rho_K, qv_K, rhoYks, pres, T, pres_mag=pres_mag) qK_prim_vf(E_idx)%sf(j, k, l) = pres @@ -809,19 +705,18 @@ contains vftmp = qK_cons_vf(alf_idx)%sf(j, k, l) if (qbmm) then - !Get nb (constant across all R0 bins) + ! Get nb (constant across all R0 bins) nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) - !Convert cons to prim + ! Convert cons to prim $:GPU_LOOP(parallelism='[seq]') do i = bubxb, bubxe qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/nbub_sc end do - !Need to keep track of nb in the primitive variable list (converted back to true value before output) + ! Need to keep track of nb in the primitive variable list (converted back to true value before output) #ifdef MFC_SIMULATION qK_prim_vf(bubxb)%sf(j, k, l) = qK_cons_vf(bubxb)%sf(j, k, l) #endif - else if (adv_n) then qK_prim_vf(n_idx)%sf(j, k, l) = qK_cons_vf(n_idx)%sf(j, k, l) @@ -857,12 +752,12 @@ contains do i = strxb, strxe ! subtracting elastic contribution for pressure calculation if (G_K > verysmall) then - qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - & - ((qK_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G_K))/gamma_K + qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - ((qK_prim_vf(i)%sf(j, k, & + & l)**2._wp)/(4._wp*G_K))/gamma_K ! Double for shear stresses if (any(i == shear_indices)) then - qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - & - ((qK_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G_K))/gamma_K + qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - ((qK_prim_vf(i)%sf(j, k, & + & l)**2._wp)/(4._wp*G_K))/gamma_K end if end if end do @@ -892,49 +787,40 @@ contains #ifdef MFC_POST_PROCESS if (bubbles_lagrange) qK_prim_vf(beta_idx)%sf(j, k, l) = qK_cons_vf(beta_idx)%sf(j, k, l) #endif - end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_convert_conservative_to_primitive_variables - - !> The following procedure handles the conversion between - !! the primitive variables and the conservative variables. - !! @param q_prim_vf Primitive variables - !! @param q_cons_vf Conservative variables - impure subroutine s_convert_primitive_to_conservative_variables(q_prim_vf, & - q_cons_vf) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + !> The following procedure handles the conversion between the primitive variables and the conservative variables. + !! @param q_prim_vf Primitive variables + !! @param q_cons_vf Conservative variables + impure subroutine s_convert_primitive_to_conservative_variables(q_prim_vf, q_cons_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf ! Density, specific heat ratio function, liquid stiffness function ! and dynamic pressure, as defined in the incompressible flow sense, ! respectively - real(wp) :: rho - real(wp) :: gamma - real(wp) :: pi_inf - real(wp) :: qv - real(wp) :: dyn_pres - real(wp) :: nbub, R3tmp - real(wp), dimension(nb) :: Rtmp - real(wp) :: G - real(wp), dimension(2) :: Re_K - - integer :: i, j, k, l !< Generic loop iterators - + real(wp) :: rho + real(wp) :: gamma + real(wp) :: pi_inf + real(wp) :: qv + real(wp) :: dyn_pres + real(wp) :: nbub, R3tmp + real(wp), dimension(nb) :: Rtmp + real(wp) :: G + real(wp), dimension(2) :: Re_K + integer :: i, j, k, l !< Generic loop iterators real(wp), dimension(num_species) :: Ys - real(wp) :: e_mix, mix_mol_weight, T - real(wp) :: pres_mag - - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: h ! relativistic enthalpy - real(wp) :: v2 ! Square of the velocity magnitude - real(wp) :: B2 ! Square of the magnetic field magnitude - real(wp) :: vdotB ! Dot product of the velocity and magnetic field vectors - real(wp) :: B(3) ! Magnetic field components + real(wp) :: e_mix, mix_mol_weight, T + real(wp) :: pres_mag + real(wp) :: Ga ! Lorentz factor (gamma in relativity) + real(wp) :: h ! relativistic enthalpy + real(wp) :: v2 ! Square of the velocity magnitude + real(wp) :: B2 ! Square of the magnetic field magnitude + real(wp) :: vdotB ! Dot product of the velocity and magnetic field vectors + real(wp) :: B(3) ! Magnetic field components pres_mag = 0._wp @@ -945,11 +831,9 @@ contains do l = 0, p do k = 0, n do j = 0, m - ! Obtaining the density, specific heat ratio function ! and the liquid stiffness function, respectively - call s_convert_to_mixture_variables(q_prim_vf, j, k, l, & - rho, gamma, pi_inf, qv, Re_K, G, fluid_pp(:)%G) + call s_convert_to_mixture_variables(q_prim_vf, j, k, l, rho, gamma, pi_inf, qv, Re_K, G, fluid_pp(:)%G) if (.not. igr .or. num_fluids > 1) then ! Transferring the advection equation(s) variable(s) @@ -959,7 +843,6 @@ contains end if if (relativity) then - if (n == 0) then B(1) = Bx0 B(2) = q_prim_vf(B_idx%beg)%sf(j, k, l) @@ -996,12 +879,10 @@ contains end do do i = momxb, momxe - q_cons_vf(i)%sf(j, k, l) = (rho*h*Ga**2 + B2)*q_prim_vf(i)%sf(j, k, l) & - - vdotB*B(i - momxb + 1) + q_cons_vf(i)%sf(j, k, l) = (rho*h*Ga**2 + B2)*q_prim_vf(i)%sf(j, k, l) - vdotB*B(i - momxb + 1) end do - q_cons_vf(E_idx)%sf(j, k, l) = rho*h*Ga**2 - q_prim_vf(E_idx)%sf(j, k, l) & - + 0.5_wp*(B2 + v2*B2 - vdotB**2) + q_cons_vf(E_idx)%sf(j, k, l) = rho*h*Ga**2 - q_prim_vf(E_idx)%sf(j, k, l) + 0.5_wp*(B2 + v2*B2 - vdotB**2) ! Remove rest energy do i = 1, contxe q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) - q_cons_vf(i)%sf(j, k, l) @@ -1012,7 +893,6 @@ contains end do cycle ! skip all the non-relativistic conversions below - end if ! Transferring the continuity equation(s) variable(s) @@ -1027,8 +907,7 @@ contains ! Computing momenta and dynamic pressure from velocity do i = momxb, momxe q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) - dyn_pres = dyn_pres + q_cons_vf(i)%sf(j, k, l)* & - q_prim_vf(i)%sf(j, k, l)/2._wp + dyn_pres = dyn_pres + q_cons_vf(i)%sf(j, k, l)*q_prim_vf(i)%sf(j, k, l)/2._wp end do if (chemistry) then @@ -1041,30 +920,27 @@ contains T = q_prim_vf(E_idx)%sf(j, k, l)*mix_mol_weight/(gas_constant*rho) call get_mixture_energy_mass(T, Ys, e_mix) - q_cons_vf(E_idx)%sf(j, k, l) = & - dyn_pres + rho*e_mix + q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + rho*e_mix else ! Computing the energy from the pressure if (mhd) then if (n == 0) then - pres_mag = 0.5_wp*(Bx0**2 + q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, l)**2) + pres_mag = 0.5_wp*(Bx0**2 + q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, & + & k, l)**2) else - pres_mag = 0.5_wp*(q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) + pres_mag = 0.5_wp*(q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, & + & l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if - q_cons_vf(E_idx)%sf(j, k, l) = & - gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pres_mag & - + pi_inf + qv - elseif ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then + q_cons_vf(E_idx)%sf(j, k, l) = gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pres_mag + pi_inf + qv + else if ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then ! E = Gamma*P + \rho u u /2 + \pi_inf + (\alpha\rho qv) - q_cons_vf(E_idx)%sf(j, k, l) = & - gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pi_inf + qv + q_cons_vf(E_idx)%sf(j, k, l) = gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pi_inf + qv else if ((model_eqns /= 4) .and. (bubbles_euler)) then ! \tilde{E} = dyn_pres + (1-\alf)(\Gamma p_l + \Pi_inf) - q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + & - (1._wp - q_prim_vf(alf_idx)%sf(j, k, l))* & - (gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) + q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + (1._wp - q_prim_vf(alf_idx)%sf(j, k, & + & l))*(gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) else - !Tait EOS, no conserved energy variable + ! Tait EOS, no conserved energy variable q_cons_vf(E_idx)%sf(j, k, l) = 0._wp end if end if @@ -1073,9 +949,9 @@ contains if (model_eqns == 3) then do i = 1, num_fluids ! internal energy calculation for each of the fluids - q_cons_vf(i + intxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, l)* & - (gammas(i)*q_prim_vf(E_idx)%sf(j, k, l) + pi_infs(i)) + & - q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) + q_cons_vf(i + intxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, & + & l)*(gammas(i)*q_prim_vf(E_idx)%sf(j, k, & + & l) + pi_infs(i)) + q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) end do end if @@ -1093,13 +969,13 @@ contains call s_comp_n_from_prim(real(q_prim_vf(alf_idx)%sf(j, k, l), kind=wp), Rtmp, nbub, weight) end if else - !Initialize R3 averaging over R0 and R directions + ! Initialize R3 averaging over R0 and R directions R3tmp = 0._wp do i = 1, nb R3tmp = R3tmp + weight(i)*0.5_wp*(Rtmp(i) + sigR)**3._wp R3tmp = R3tmp + weight(i)*0.5_wp*(Rtmp(i) - sigR)**3._wp end do - !Initialize nb + ! Initialize nb nbub = 3._wp*q_prim_vf(alf_idx)%sf(j, k, l)/(4._wp*pi*R3tmp) end if @@ -1127,12 +1003,12 @@ contains do i = strxb, strxe ! adding elastic contribution if (G > verysmall) then - q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + & - (q_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G) + q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + (q_prim_vf(i)%sf(j, k, & + & l)**2._wp)/(4._wp*G) ! Double for shear stresses if (any(i == shear_indices)) then - q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + & - (q_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G) + q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + (q_prim_vf(i)%sf(j, k, & + & l)**2._wp)/(4._wp*G) end if end if end do @@ -1153,82 +1029,71 @@ contains if (cont_damage) q_cons_vf(damage_idx)%sf(j, k, l) = q_prim_vf(damage_idx)%sf(j, k, l) if (hyper_cleaning) q_cons_vf(psi_idx)%sf(j, k, l) = q_prim_vf(psi_idx)%sf(j, k, l) - end do end do end do #else if (proc_rank == 0) then - call s_mpi_abort('Conversion from primitive to '// & - 'conservative variables not '// & - 'implemented. Exiting.') + call s_mpi_abort('Conversion from primitive to ' // 'conservative variables not ' // 'implemented. Exiting.') end if #endif end subroutine s_convert_primitive_to_conservative_variables - - !> The following subroutine handles the conversion between - !! the primitive variables and the Eulerian flux variables. - !! @param qK_prim_vf Primitive variables - !! @param FK_vf Flux variables - !! @param FK_src_vf Flux source variables - !! @param is1 Index bounds in the first coordinate direction - !! @param is2 Index bounds in the second coordinate direction - !! @param is3 Index bounds in the third coordinate direction - !! @param s2b Starting boundary index in the second coordinate direction - !! @param s3b Starting boundary index in the third coordinate direction - subroutine s_convert_primitive_to_flux_variables(qK_prim_vf, & - FK_vf, & - FK_src_vf, & - is1, is2, is3, s2b, s3b) - - integer, intent(in) :: s2b, s3b - real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: qK_prim_vf - real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: FK_vf + !> The following subroutine handles the conversion between the primitive variables and the Eulerian flux variables. + !! @param qK_prim_vf Primitive variables + !! @param FK_vf Flux variables + !! @param FK_src_vf Flux source variables + !! @param is1 Index bounds in the first coordinate direction + !! @param is2 Index bounds in the second coordinate direction + !! @param is3 Index bounds in the third coordinate direction + !! @param s2b Starting boundary index in the second coordinate direction + !! @param s3b Starting boundary index in the third coordinate direction + subroutine s_convert_primitive_to_flux_variables(qK_prim_vf, FK_vf, FK_src_vf, is1, is2, is3, s2b, s3b) + integer, intent(in) :: s2b, s3b + real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: qK_prim_vf + real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: FK_vf real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, advxb:), intent(inout) :: FK_src_vf - - type(int_bounds_info), intent(in) :: is1, is2, is3 + type(int_bounds_info), intent(in) :: is1, is2, is3 ! Partial densities, density, velocity, pressure, energy, advection ! variables, the specific heat ratio and liquid stiffness functions, ! the shear and volume Reynolds numbers and the Weber numbers #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha_rho_K - real(wp), dimension(3) :: alpha_K - real(wp), dimension(3) :: vel_K + real(wp), dimension(3) :: alpha_rho_K + real(wp), dimension(3) :: alpha_K + real(wp), dimension(3) :: vel_K real(wp), dimension(10) :: Y_K #:else - real(wp), dimension(num_fluids) :: alpha_rho_K - real(wp), dimension(num_fluids) :: alpha_K - real(wp), dimension(num_vels) :: vel_K + real(wp), dimension(num_fluids) :: alpha_rho_K + real(wp), dimension(num_fluids) :: alpha_K + real(wp), dimension(num_vels) :: vel_K real(wp), dimension(num_species) :: Y_K #:endif - real(wp) :: rho_K - real(wp) :: vel_K_sum - real(wp) :: pres_K - real(wp) :: E_K - real(wp) :: gamma_K - real(wp) :: pi_inf_K - real(wp) :: qv_K + real(wp) :: rho_K + real(wp) :: vel_K_sum + real(wp) :: pres_K + real(wp) :: E_K + real(wp) :: gamma_K + real(wp) :: pi_inf_K + real(wp) :: qv_K real(wp), dimension(2) :: Re_K - real(wp) :: G_K - real(wp) :: T_K, mix_mol_weight, R_gas - - integer :: i, j, k, l !< Generic loop iterators + real(wp) :: G_K + real(wp) :: T_K, mix_mol_weight, R_gas + integer :: i, j, k, l !< Generic loop iterators is1b = is1%beg; is1e = is1%end is2b = is2%beg; is2e = is2%end is3b = is3%beg; is3e = is3%end - $:GPU_UPDATE(device='[is1b,is2b,is3b,is1e,is2e,is3e]') + $:GPU_UPDATE(device='[is1b, is2b, is3b, is1e, is2e, is3e]') ! Computing the flux variables from the primitive variables, without ! accounting for the contribution of either viscosity or capillarity #ifdef MFC_SIMULATION - $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_rho_K, vel_K, alpha_K, Re_K, Y_K, rho_K, vel_K_sum, pres_K, E_K, gamma_K, pi_inf_K, qv_K, G_K, T_K, mix_mol_weight, R_gas]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_rho_K, vel_K, alpha_K, Re_K, Y_K, rho_K, vel_K_sum, pres_K, E_K, gamma_K, & + & pi_inf_K, qv_K, G_K, T_K, mix_mol_weight, R_gas]') do l = is3b, is3e do k = is2b, is2e do j = is1b, is1e - $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe alpha_rho_K(i) = qK_prim_vf(j, k, l, i) @@ -1252,12 +1117,10 @@ contains pres_K = qK_prim_vf(j, k, l, E_idx) if (elasticity) then - call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, & - G_K, Gs_vc) + call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & + & Re_K, G_K, Gs_vc) else - call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K) + call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K) end if ! Computing the energy from the pressure @@ -1267,7 +1130,7 @@ contains do i = chemxb, chemxe Y_K(i - chemxb + 1) = qK_prim_vf(j, k, l, i) end do - !Computing the energy from the internal energy of the mixture + ! Computing the energy from the internal energy of the mixture call get_mixture_molecular_weight(Y_k, mix_mol_weight) R_gas = gas_constant/mix_mol_weight T_K = pres_K/rho_K/R_gas @@ -1275,8 +1138,7 @@ contains E_K = rho_K*E_K + 5.e-1_wp*rho_K*vel_K_sum else ! Computing the energy from the pressure - E_K = gamma_K*pres_K + pi_inf_K & - + 5.e-1_wp*rho_K*vel_K_sum + qv_K + E_K = gamma_K*pres_K + pi_inf_K + 5.e-1_wp*rho_K*vel_K_sum + qv_K end if ! mass flux, this should be \alpha_i \rho_i u_i @@ -1287,10 +1149,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels - FK_vf(j, k, l, contxe + dir_idx(i)) = & - rho_K*vel_K(dir_idx(1)) & - *vel_K(dir_idx(i)) & - + pres_K*dir_flg(dir_idx(i)) + FK_vf(j, k, l, contxe + dir_idx(i)) = rho_K*vel_K(dir_idx(1))*vel_K(dir_idx(i)) + pres_K*dir_flg(dir_idx(i)) end do ! energy flux, u(E+p) @@ -1310,7 +1169,6 @@ contains FK_vf(j, k, l, i) = 0._wp FK_src_vf(j, k, l, i) = alpha_K(i - E_idx) end do - else ! Could be bubbles_euler! $:GPU_LOOP(parallelism='[seq]') @@ -1322,28 +1180,24 @@ contains do i = advxb, advxe FK_src_vf(j, k, l, i) = vel_K(dir_idx(1)) end do - end if - end do end do end do $:END_GPU_PARALLEL_LOOP() #endif end subroutine s_convert_primitive_to_flux_variables - - !> This subroutine computes partial densities and volume fractions + !> This subroutine computes partial densities and volume fractions subroutine s_compute_species_fraction(q_vf, k, l, r, alpha_rho_K, alpha_K) - $:GPU_ROUTINE(function_name='s_compute_species_fraction', & - & parallelism='[seq]', cray_noinline=True) + $:GPU_ROUTINE(function_name='s_compute_species_fraction', parallelism='[seq]', cray_noinline=True) type(scalar_field), dimension(sys_size), intent(in) :: q_vf - integer, intent(in) :: k, l, r + integer, intent(in) :: k, l, r #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3), intent(out) :: alpha_rho_K, alpha_K #:else real(wp), dimension(num_fluids), intent(out) :: alpha_rho_K, alpha_K #:endif - integer :: i + integer :: i real(wp) :: alpha_K_sum if (num_fluids == 1) then @@ -1380,12 +1234,9 @@ contains end if if (num_fluids == 1 .and. bubbles_euler) alpha_K(1) = q_vf(advxb)%sf(k, l, r) - end subroutine s_compute_species_fraction - !> @brief Deallocates fluid property arrays and post-processing fields allocated during module initialization. impure subroutine s_finalize_variables_conversion_module() - ! Deallocating the density, the specific heat ratio function and the ! liquid stiffness function #ifdef MFC_POST_PROCESS @@ -1403,9 +1254,7 @@ contains @:DEALLOCATE(bubrs_vc) end if #endif - end subroutine s_finalize_variables_conversion_module - #ifndef MFC_PRE_PROCESS !> @brief Computes the speed of sound from thermodynamic state variables, supporting multiple equation-of-state models. subroutine s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, vel_sum, c_c, c, qv) @@ -1419,13 +1268,11 @@ contains #:else real(wp), dimension(num_fluids), intent(in) :: adv #:endif - real(wp), intent(in) :: vel_sum - real(wp), intent(in) :: c_c + real(wp), intent(in) :: vel_sum + real(wp), intent(in) :: c_c real(wp), intent(out) :: c - - real(wp) :: blkmod1, blkmod2 - - integer :: q + real(wp) :: blkmod1, blkmod2 + integer :: q if (chemistry) then if (avg_state == 1 .and. abs(c_c) > verysmall) then @@ -1433,35 +1280,28 @@ contains else c = sqrt((1.0_wp + 1.0_wp/gamma)*pres/rho) end if - elseif (relativity) then + else if (relativity) then ! Only supports perfect gas for now c = sqrt((1._wp + 1._wp/gamma)*pres/rho/H) else if (alt_soundspeed) then - blkmod1 = ((gammas(1) + 1._wp)*pres + & - pi_infs(1))/gammas(1) - blkmod2 = ((gammas(2) + 1._wp)*pres + & - pi_infs(2))/gammas(2) + blkmod1 = ((gammas(1) + 1._wp)*pres + pi_infs(1))/gammas(1) + blkmod2 = ((gammas(2) + 1._wp)*pres + pi_infs(2))/gammas(2) c = (1._wp/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) - elseif (model_eqns == 3) then + else if (model_eqns == 3) then c = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, num_fluids - c = c + adv(q)*gs_min(q)* & - (pres + pi_infs(q)/(gammas(q) + 1._wp)) + c = c + adv(q)*gs_min(q)*(pres + pi_infs(q)/(gammas(q) + 1._wp)) end do c = c/rho - elseif (((model_eqns == 4) .or. (model_eqns == 2 .and. bubbles_euler))) then + else if (((model_eqns == 4) .or. (model_eqns == 2 .and. bubbles_euler))) then ! Sound speed for bubble mixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then - c = (1._wp/gamma + 1._wp)* & - (pres + pi_inf/(gamma + 1._wp))/rho + c = (1._wp/gamma + 1._wp)*(pres + pi_inf/(gamma + 1._wp))/rho else - c = & - (1._wp/gamma + 1._wp)* & - (pres + pi_inf/(gamma + 1._wp))/ & - (rho*(1._wp - adv(num_fluids))) + c = (1._wp/gamma + 1._wp)*(pres + pi_inf/(gamma + 1._wp))/(rho*(1._wp - adv(num_fluids))) end if else c = (H - 5.e-1*vel_sum - qv/rho)/gamma @@ -1479,15 +1319,13 @@ contains #ifndef MFC_PRE_PROCESS !> @brief Computes the fast magnetosonic wave speed from the sound speed, density, and magnetic field components. subroutine s_compute_fast_magnetosonic_speed(rho, c, B, norm, c_fast, h) - $:GPU_ROUTINE(function_name='s_compute_fast_magnetosonic_speed', & - & parallelism='[seq]', cray_noinline=True) + $:GPU_ROUTINE(function_name='s_compute_fast_magnetosonic_speed', parallelism='[seq]', cray_noinline=True) - real(wp), intent(in) :: B(3), rho, c - real(wp), intent(in) :: h ! only used for relativity + real(wp), intent(in) :: B(3), rho, c + real(wp), intent(in) :: h ! only used for relativity real(wp), intent(out) :: c_fast - integer, intent(in) :: norm - - real(wp) :: B2, term, disc + integer, intent(in) :: norm + real(wp) :: B2, term, disc B2 = sum(B**2) @@ -1508,8 +1346,6 @@ contains #endif c_fast = sqrt(0.5_wp*(term + sqrt(disc))) - end subroutine s_compute_fast_magnetosonic_speed #endif - end module m_variables_conversion diff --git a/src/post_process/m_checker.fpp b/src/post_process/m_checker.fpp index 13587887a8..ecca4fe836 100644 --- a/src/post_process/m_checker.fpp +++ b/src/post_process/m_checker.fpp @@ -6,7 +6,6 @@ !> @brief Validates post-process input parameters and output format consistency module m_checker - use m_global_parameters !< Definitions of the global parameters use m_mpi_proxy !< Message passing interface (MPI) module proxy @@ -18,14 +17,11 @@ module m_checker implicit none private; public :: s_check_inputs, s_check_inputs_fft - contains - !> Checks compatibility of parameters in the input file. - !! Used by the post_process stage + !> Checks compatibility of parameters in the input file. Used by the post_process stage impure subroutine s_check_inputs end subroutine s_check_inputs - !> Checks constraints on fft_wrt impure subroutine s_check_inputs_fft integer :: num_procs_y, num_procs_z @@ -37,5 +33,4 @@ contains @:PROHIBIT(fft_wrt .and. MOD(m_glb+1,num_procs_y) /= 0, "FFT WRT requires m_glb to be divisible by num_procs_y") @:PROHIBIT(fft_wrt .and. MOD(n_glb+1,num_procs_z) /= 0, "FFT WRT requires n_glb to be divisible by num_procs_z") end subroutine s_check_inputs_fft - end module m_checker diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index be1bdcb2d2..d6cf2856e8 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -4,7 +4,6 @@ !> @brief Reads raw simulation grid and conservative-variable data for a given time-step and fills buffer regions module m_data_input - #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -25,35 +24,28 @@ module m_data_input implicit none - private; public :: s_initialize_data_input_module, & - s_read_data_files, & - s_read_serial_data_files, & - s_read_parallel_data_files, & - s_finalize_data_input_module + private; public :: s_initialize_data_input_module, s_read_data_files, s_read_serial_data_files, s_read_parallel_data_files, & + & s_finalize_data_input_module abstract interface !> Subroutine for reading data files - !! @param t_step Current time-step to input + !! @param t_step Current time-step to input impure subroutine s_read_abstract_data_files(t_step) - implicit none integer, intent(in) :: t_step - end subroutine s_read_abstract_data_files - end interface type(scalar_field), allocatable, dimension(:), public :: q_cons_vf !< !! Conservative variables type(scalar_field), allocatable, dimension(:), public :: q_cons_temp - type(scalar_field), allocatable, dimension(:), public :: q_prim_vf !< !! Primitive variables - type(integer_field), allocatable, dimension(:, :), public :: bc_type !< + type(integer_field), allocatable, dimension(:,:), public :: bc_type !< !! Boundary condition identifiers type(scalar_field), public :: q_T_sf !< @@ -63,41 +55,36 @@ end subroutine s_read_abstract_data_files type(integer_field), public :: ib_markers procedure(s_read_abstract_data_files), pointer :: s_read_data_files => null() - contains !> Helper subroutine to read grid data files for a given direction - !! @param t_step_dir Directory containing the time-step data - !! @param direction Direction name ('x', 'y', 'z') - !! @param cb_array Cell boundary array to populate - !! @param d_array Cell width array to populate - !! @param cc_array Cell center array to populate - !! @param size_dim Size of the dimension + !! @param t_step_dir Directory containing the time-step data + !! @param direction Direction name ('x', 'y', 'z') + !! @param cb_array Cell boundary array to populate + !! @param d_array Cell width array to populate + !! @param cc_array Cell center array to populate + !! @param size_dim Size of the dimension impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_array, cc_array, size_dim) - - character(len=*), intent(in) :: t_step_dir - character(len=1), intent(in) :: direction - real(wp), dimension(-1:), intent(out) :: cb_array - real(wp), dimension(0:), intent(out) :: d_array - real(wp), dimension(0:), intent(out) :: cc_array - integer, intent(in) :: size_dim - + character(len=*), intent(in) :: t_step_dir + character(len=1), intent(in) :: direction + real(wp), dimension(-1:), intent(out) :: cb_array + real(wp), dimension(0:), intent(out) :: d_array + real(wp), dimension(0:), intent(out) :: cc_array + integer, intent(in) :: size_dim character(LEN=len_trim(t_step_dir) + 10) :: file_loc - logical :: file_check + logical :: file_check ! Checking whether direction_cb.dat exists - file_loc = trim(t_step_dir)//'/'//direction//'_cb.dat' + file_loc = trim(t_step_dir) // '/' // direction // '_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) ! Reading direction_cb.dat if it exists, exiting otherwise if (file_check) then - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS='old', ACTION='read') + open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) cb_array(-1:size_dim) close (1) else - call s_mpi_abort('File '//direction//'_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting.') + call s_mpi_abort('File ' // direction // '_cb.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if ! Computing the cell-width distribution @@ -105,17 +92,14 @@ impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_ ! Computing the cell-center locations cc_array(0:size_dim) = cb_array(-1:size_dim - 1) + d_array(0:size_dim)/2._wp - end subroutine s_read_grid_data_direction - #ifdef MFC_MPI !> Helper subroutine to setup MPI data I/O parameters - !! @param data_size Local array size (output) - !! @param m_MOK, n_MOK, p_MOK MPI offset kinds for dimensions (output) - !! @param WP_MOK, MOK, str_MOK, NVARS_MOK Other MPI offset kinds (output) + !! @param data_size Local array size (output) + !! @param m_MOK, n_MOK, p_MOK MPI offset kinds for dimensions (output) + !! @param WP_MOK, MOK, str_MOK, NVARS_MOK Other MPI offset kinds (output) impure subroutine s_setup_mpi_io_params(data_size, m_MOK, n_MOK, p_MOK, WP_MOK, MOK, str_MOK, NVARS_MOK) - - integer, intent(out) :: data_size + integer, intent(out) :: data_size integer(KIND=MPI_OFFSET_KIND), intent(out) :: m_MOK, n_MOK, p_MOK integer(KIND=MPI_OFFSET_KIND), intent(out) :: WP_MOK, MOK, str_MOK, NVARS_MOK @@ -137,34 +121,30 @@ impure subroutine s_setup_mpi_io_params(data_size, m_MOK, n_MOK, p_MOK, WP_MOK, MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - end subroutine s_setup_mpi_io_params #endif !> Helper subroutine to read IB data files - !! @param file_loc_base Base file location for IB data - !! @param t_step Time step index + !! @param file_loc_base Base file location for IB data + !! @param t_step Time step index impure subroutine s_read_ib_data_files(file_loc_base, t_step) - - character(len=*), intent(in) :: file_loc_base - integer, intent(in), optional :: t_step - + character(len=*), intent(in) :: file_loc_base + integer, intent(in), optional :: t_step character(LEN=len_trim(file_loc_base) + 20) :: file_loc - logical :: file_exist - integer :: ifile, ierr, data_size, var_MOK + logical :: file_exist + integer :: ifile, ierr, data_size, var_MOK #ifdef MFC_MPI integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer :: m_MOK, n_MOK, p_MOK, MOK, WP_MOK, save_index - + integer(KIND=MPI_OFFSET_KIND) :: disp + integer :: m_MOK, n_MOK, p_MOK, MOK, WP_MOK, save_index #endif if (.not. ib) return if (parallel_io) then - write (file_loc, '(A)') trim(file_loc_base)//'ib.dat' + write (file_loc, '(A)') trim(file_loc_base) // 'ib.dat' else - write (file_loc, '(A)') trim(file_loc_base)//'/ib_data.dat' + write (file_loc, '(A)') trim(file_loc_base) // '/ib_data.dat' end if inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -188,36 +168,28 @@ impure subroutine s_read_ib_data_files(file_loc_base, t_step) disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1 + int(save_index, MPI_OFFSET_KIND)) end if - call MPI_FILE_SET_VIEW(ifile, disp, MPI_INTEGER, MPI_IO_IB_DATA%view, & - 'native', mpi_info_int, ierr) - call MPI_FILE_READ(ifile, MPI_IO_IB_DATA%var%sf, data_size, & - MPI_INTEGER, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, MPI_INTEGER, MPI_IO_IB_DATA%view, 'native', mpi_info_int, ierr) + call MPI_FILE_READ(ifile, MPI_IO_IB_DATA%var%sf, data_size, MPI_INTEGER, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) #endif else - open (2, FILE=trim(file_loc), & - FORM='unformatted', & - ACTION='read', & - STATUS='old') + open (2, FILE=trim(file_loc), form='unformatted', ACTION='read', STATUS='old') read (2) ib_markers%sf(0:m, 0:n, 0:p) close (2) end if else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if - end subroutine s_read_ib_data_files - !> Helper subroutine to allocate field arrays for given dimensionality - !! @param local_start_idx Starting index for allocation - !! @param end_x End index for x dimension - !! @param end_y End index for y dimension - !! @param end_z End index for z dimension + !! @param local_start_idx Starting index for allocation + !! @param end_x End index for x dimension + !! @param end_y End index for y dimension + !! @param end_z End index for z dimension impure subroutine s_allocate_field_arrays(local_start_idx, end_x, end_y, end_z) - integer, intent(in) :: local_start_idx, end_x, end_y, end_z - integer :: i + integer :: i do i = 1, sys_size allocate (q_cons_vf(i)%sf(local_start_idx:end_x, local_start_idx:end_y, local_start_idx:end_z)) @@ -231,26 +203,19 @@ impure subroutine s_allocate_field_arrays(local_start_idx, end_x, end_y, end_z) if (chemistry) then allocate (q_T_sf%sf(local_start_idx:end_x, local_start_idx:end_y, local_start_idx:end_z)) end if - end subroutine s_allocate_field_arrays - - !> This subroutine is called at each time-step that has to - !! be post-processed in order to read the raw data files - !! present in the corresponding time-step directory and to - !! populate the associated grid and conservative variables. - !! @param t_step Current time-step + !> This subroutine is called at each time-step that has to be post-processed in order to read the raw data files present in the + !! corresponding time-step directory and to populate the associated grid and conservative variables. + !! @param t_step Current time-step impure subroutine s_read_serial_data_files(t_step) - - integer, intent(in) :: t_step - + integer, intent(in) :: t_step character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_dir !< !! Location of the time-step directory associated with t_step character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc !< !! Generic string used to store the location of a particular file - character(LEN= & - int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< !! Used to store the variable position, in character form, of the !! currently manipulated conservative variable file @@ -267,16 +232,15 @@ impure subroutine s_read_serial_data_files(t_step) ! Setting location of time-step folder based on current time-step write (t_step_dir, '(A,I0,A,I0)') '/p_all/p', proc_rank, '/', t_step - t_step_dir = trim(case_dir)//trim(t_step_dir) + t_step_dir = trim(case_dir) // trim(t_step_dir) ! Inquiring as to the existence of the time-step directory - file_loc = trim(t_step_dir)//'/.' + file_loc = trim(t_step_dir) // '/.' call my_inquire(file_loc, dir_check) ! If the time-step directory is missing, the post-process exits. if (dir_check .neqv. .true.) then - call s_mpi_abort('Time-step folder '//trim(t_step_dir)// & - ' is missing. Exiting.') + call s_mpi_abort('Time-step folder ' // trim(t_step_dir) // ' is missing. Exiting.') end if if (bc_io) then @@ -298,18 +262,15 @@ impure subroutine s_read_serial_data_files(t_step) ! Reading the Conservative Variables Data Files do i = 1, sys_size - ! Checking whether the data file associated with the variable ! position of currently manipulated conservative variable exists write (file_num, '(I0)') i - file_loc = trim(t_step_dir)//'/q_cons_vf'// & - trim(file_num)//'.dat' + file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) ! Reading the data file if it exists, exiting otherwise if (file_check) then - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS='old', ACTION='read') + open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) q_cons_vf(i)%sf(0:m, 0:n, 0:p) close (1) else if (bubbles_lagrange .and. i == beta_idx) then @@ -317,48 +278,35 @@ impure subroutine s_read_serial_data_files(t_step) ! for t_step_start; initialize to zero. q_cons_vf(i)%sf(0:m, 0:n, 0:p) = 0._wp else - call s_mpi_abort('File q_cons_vf'//trim(file_num)// & - '.dat is missing in '//trim(t_step_dir)// & - '. Exiting.') + call s_mpi_abort('File q_cons_vf' // trim(file_num) // '.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if - end do ! Reading IB data using helper subroutine call s_read_ib_data_files(t_step_dir) - end subroutine s_read_serial_data_files - - !> This subroutine is called at each time-step that has to - !! be post-processed in order to parallel-read the raw data files - !! present in the corresponding time-step directory and to - !! populate the associated grid and conservative variables. - !! @param t_step Current time-step + !> This subroutine is called at each time-step that has to be post-processed in order to parallel-read the raw data files + !! present in the corresponding time-step directory and to populate the associated grid and conservative variables. + !! @param t_step Current time-step impure subroutine s_read_parallel_data_files(t_step) - integer, intent(in) :: t_step #ifdef MFC_MPI - real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb - - integer :: ifile, ierr, data_size, filetype, stride - integer, dimension(MPI_STATUS_SIZE) :: status - - integer(KIND=MPI_OFFSET_KIND) :: disp - integer(KIND=MPI_OFFSET_KIND) :: m_MOK, n_MOK, p_MOK - integer(KIND=MPI_OFFSET_KIND) :: WP_MOK, var_MOK, str_MOK - integer(KIND=MPI_OFFSET_KIND) :: NVARS_MOK - integer(KIND=MPI_OFFSET_KIND) :: MOK - integer(kind=MPI_OFFSET_KIND) :: offset - real(wp) :: delx, dely, delz - + real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb + integer :: ifile, ierr, data_size, filetype, stride + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer(KIND=MPI_OFFSET_KIND) :: m_MOK, n_MOK, p_MOK + integer(KIND=MPI_OFFSET_KIND) :: WP_MOK, var_MOK, str_MOK + integer(KIND=MPI_OFFSET_KIND) :: NVARS_MOK + integer(KIND=MPI_OFFSET_KIND) :: MOK + integer(kind=MPI_OFFSET_KIND) :: offset + real(wp) :: delx, dely, delz character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist - - character(len=10) :: t_step_string - - integer :: i + logical :: file_exist + character(len=10) :: t_step_string + integer :: i allocate (x_cb_glb(-1:m_glb)) allocate (y_cb_glb(-1:n_glb)) @@ -371,7 +319,7 @@ impure subroutine s_read_parallel_data_files(t_step) end if ! Read in cell boundary locations in x-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'x_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'x_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -387,7 +335,7 @@ impure subroutine s_read_parallel_data_files(t_step) call MPI_FILE_READ(ifile, x_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if ! Assigning local cell boundary locations @@ -399,7 +347,7 @@ impure subroutine s_read_parallel_data_files(t_step) if (n > 0) then ! Read in cell boundary locations in y-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'y_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'y_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -415,7 +363,7 @@ impure subroutine s_read_parallel_data_files(t_step) call MPI_FILE_READ(ifile, y_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if ! Assigning local cell boundary locations @@ -427,7 +375,7 @@ impure subroutine s_read_parallel_data_files(t_step) if (p > 0) then ! Read in cell boundary locations in z-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'z_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'z_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -443,7 +391,7 @@ impure subroutine s_read_parallel_data_files(t_step) call MPI_FILE_READ(ifile, z_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if ! Assigning local cell boundary locations @@ -464,35 +412,30 @@ impure subroutine s_read_parallel_data_files(t_step) else call s_assign_default_bc_type(bc_type) end if - #endif - end subroutine s_read_parallel_data_files - #ifdef MFC_MPI !> Helper subroutine to read parallel conservative variable data - !! @param t_step Current time-step - !! @param m_MOK, n_MOK, p_MOK MPI offset kinds for dimensions - !! @param WP_MOK, MOK, str_MOK, NVARS_MOK Other MPI offset kinds + !! @param t_step Current time-step + !! @param m_MOK, n_MOK, p_MOK MPI offset kinds for dimensions + !! @param WP_MOK, MOK, str_MOK, NVARS_MOK Other MPI offset kinds impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, WP_MOK, MOK, str_MOK, NVARS_MOK) - - integer, intent(in) :: t_step + integer, intent(in) :: t_step integer(KIND=MPI_OFFSET_KIND), intent(inout) :: m_MOK, n_MOK, p_MOK integer(KIND=MPI_OFFSET_KIND), intent(inout) :: WP_MOK, MOK, str_MOK, NVARS_MOK - - integer :: ifile, ierr, data_size - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp, var_MOK - character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist - character(len=10) :: t_step_string - integer :: i + integer :: ifile, ierr, data_size + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp, var_MOK + character(LEN=path_len + 2*name_len) :: file_loc + logical :: file_exist + character(len=10) :: t_step_string + integer :: i if (file_per_process) then call s_int_to_str(t_step, t_step_string) ! Open the file to read conservative variables write (file_loc, '(I0,A1,I7.7,A)') t_step, '_', proc_rank, '.dat' - file_loc = trim(case_dir)//'/restart_data/lustre_'//trim(t_step_string)//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data/lustre_' // trim(t_step_string) // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -530,14 +473,12 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, if (bubbles_euler .or. elasticity .or. mhd) then do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do else do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if @@ -550,14 +491,14 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, end do end if - call s_read_ib_data_files(trim(case_dir)//'/restart_data'//trim(mpiiofs), t_step) + call s_read_ib_data_files(trim(case_dir) // '/restart_data' // trim(mpiiofs), t_step) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if else ! Open the file to read conservative variables write (file_loc, '(I0,A)') t_step, '.dat' - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -572,27 +513,23 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do call s_mpi_barrier() call MPI_FILE_CLOSE(ifile, ierr) - call s_read_ib_data_files(trim(case_dir)//'/restart_data'//trim(mpiiofs), t_step) + call s_read_ib_data_files(trim(case_dir) // '/restart_data' // trim(mpiiofs), t_step) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if end if end subroutine s_read_parallel_conservative_data #endif - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_data_input_module - integer :: i !< Generic loop iterator ! Allocating the parts of the conservative and primitive variables @@ -644,12 +581,9 @@ impure subroutine s_initialize_data_input_module else s_read_data_files => s_read_parallel_data_files end if - end subroutine s_initialize_data_input_module - !> Deallocation procedures for the module impure subroutine s_finalize_data_input_module - integer :: i !< Generic loop iterator ! Deallocating the conservative and primitive variables @@ -684,7 +618,5 @@ impure subroutine s_finalize_data_input_module deallocate (bc_type) s_read_data_files => null() - end subroutine s_finalize_data_input_module - end module m_data_input diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 3251b3ac3b..4649573867 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -4,14 +4,13 @@ !> @brief Writes post-processed grid and flow-variable data to Silo-HDF5 or binary database files module m_data_output + use m_derived_types ! Definitions of the derived types - use m_derived_types ! Definitions of the derived types - - use m_global_parameters ! Global parameters + use m_global_parameters ! Global parameters use m_derived_variables !< Procedures used to compute quantities derived - use m_mpi_proxy ! Message passing interface (MPI) module proxy + use m_mpi_proxy ! Message passing interface (MPI) module proxy use m_compile_specific @@ -21,22 +20,12 @@ module m_data_output implicit none - private; public :: s_initialize_data_output_module, & - s_define_output_region, & - s_open_formatted_database_file, & - s_open_intf_data_file, & - s_open_energy_data_file, & - s_write_grid_to_formatted_database_file, & - 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_close_formatted_database_file, & - s_close_intf_data_file, & - s_close_energy_data_file, & - s_finalize_data_output_module + private; public :: s_initialize_data_output_module, s_define_output_region, s_open_formatted_database_file, & + & s_open_intf_data_file, s_open_energy_data_file, s_write_grid_to_formatted_database_file, & + & 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_close_formatted_database_file, s_close_intf_data_file, s_close_energy_data_file, & + & s_finalize_data_output_module ! Including the Silo Fortran interface library that features the subroutines ! and parameters that are required to write in the Silo-HDF5 database format @@ -47,21 +36,21 @@ module m_data_output ! database file(s). Note that for 1D simulations, q_root_sf is employed to ! gather the flow variable(s) from all sub-domains on to the root process. ! If the run is not parallel, but serial, then q_root_sf is equal to q_sf. - real(wp), allocatable, dimension(:, :, :), public :: q_sf - real(wp), allocatable, dimension(:, :, :) :: q_root_sf - real(wp), allocatable, dimension(:, :, :) :: cyl_q_sf + 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 + real(sp), allocatable, dimension(:,:,:), public :: q_sf_s + real(sp), allocatable, dimension(:,:,:) :: q_root_sf_s + real(sp), allocatable, dimension(:,:,:) :: cyl_q_sf_s ! The spatial and data extents array variables contain information about the ! minimum and maximum values of the grid and flow variable(s), respectively. ! The purpose of bookkeeping this information is to boost the visualization ! of the Silo-HDF5 database file(s) in VisIt. - real(wp), allocatable, dimension(:, :) :: spatial_extents - real(wp), allocatable, dimension(:, :) :: data_extents + real(wp), allocatable, dimension(:,:) :: spatial_extents + real(wp), allocatable, dimension(:,:) :: data_extents ! The size of the ghost zone layer at beginning of each coordinate direction ! (lo) and at end of each coordinate direction (hi). Adding this information @@ -86,7 +75,7 @@ module m_data_output ! 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 + name_len) :: dbdir character(LEN=path_len + 2*name_len) :: proc_rank_dir character(LEN=path_len + 2*name_len) :: rootdir @@ -106,7 +95,6 @@ module m_data_output ! Generic error flags utilized in the handling, checking and the reporting ! of the input and output operations errors with a formatted database file integer, private :: err - contains !> @brief Allocate storage arrays, configure output directories, and count flow variables for formatted database output. @@ -119,29 +107,21 @@ contains ! Generic logical used to test the existence of a particular folder logical :: dir_check - integer :: i ! Allocating the generic storage for the flow variable(s) that are ! going to be written to the formatted database file(s). Note once ! more that the root variable is only required for 1D computations. - 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 (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 (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 == 1) 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 (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 (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 @@ -157,7 +137,6 @@ contains ! in each active coordinate direction. Note that all these variables ! are only needed by the Silo-HDF5 format for multidimensional data. if (format == 1) then - allocate (data_extents(1:2, 0:num_procs - 1)) if (p > 0) then @@ -165,7 +144,7 @@ contains allocate (lo_offset(1:3)) allocate (hi_offset(1:3)) allocate (dims(1:3)) - elseif (n > 0) then + else if (n > 0) then allocate (spatial_extents(1:4, 0:num_procs - 1)) allocate (lo_offset(1:2)) allocate (hi_offset(1:2)) @@ -176,7 +155,6 @@ contains allocate (hi_offset(1:1)) allocate (dims(1:1)) end if - end if ! The size of the ghost zone layer in each of the active coordinate @@ -197,20 +175,17 @@ contains 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/) + 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/) + 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 - elseif (n > 0) then + else if (n > 0) then lo_offset(:) = (/offset_x%beg, offset_y%beg/) 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/) + 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/) @@ -220,15 +195,14 @@ contains ! Generating Silo-HDF5 Directory Tree if (format == 1) then - ! Creating the directory associated with the local process - dbdir = trim(case_dir)//'/silo_hdf5' + dbdir = trim(case_dir) // '/silo_hdf5' write (proc_rank_dir, '(A,I0)') '/p', proc_rank - proc_rank_dir = trim(dbdir)//trim(proc_rank_dir) + proc_rank_dir = trim(dbdir) // trim(proc_rank_dir) - file_loc = trim(proc_rank_dir)//'/.' + file_loc = trim(proc_rank_dir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then @@ -237,30 +211,27 @@ contains ! Creating the directory associated with the root process if (proc_rank == 0) then + rootdir = trim(dbdir) // '/root' - rootdir = trim(dbdir)//'/root' - - file_loc = trim(rootdir)//'/.' + file_loc = trim(rootdir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then call s_create_directory(trim(rootdir)) end if - end if ! Generating Binary Directory Tree - else ! Creating the directory associated with the local process - dbdir = trim(case_dir)//'/binary' + dbdir = trim(case_dir) // '/binary' write (proc_rank_dir, '(A,I0)') '/p', proc_rank - proc_rank_dir = trim(dbdir)//trim(proc_rank_dir) + proc_rank_dir = trim(dbdir) // trim(proc_rank_dir) - file_loc = trim(proc_rank_dir)//'/.' + file_loc = trim(proc_rank_dir) // '/.' call my_inquire(file_loc, dir_check) @@ -270,25 +241,22 @@ contains ! Creating the directory associated with the root process if (n == 0 .and. proc_rank == 0) then + rootdir = trim(dbdir) // '/root' - rootdir = trim(dbdir)//'/root' - - file_loc = trim(rootdir)//'/.' + file_loc = trim(rootdir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then call s_create_directory(trim(rootdir)) end if - end if - end if - if (bubbles_lagrange) then !Lagrangian solver + if (bubbles_lagrange) then ! Lagrangian solver if (lag_txt_wrt) then - dbdir = trim(case_dir)//'/lag_bubbles_post_process' - file_loc = trim(dbdir)//'/.' + dbdir = trim(case_dir) // '/lag_bubbles_post_process' + file_loc = trim(dbdir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then @@ -309,7 +277,6 @@ contains ! Querying Number of Flow Variable(s) in Binary Output if (format == 2) then - ! Initializing the counter of the number of flow variable(s) to ! be written to the formatted database file(s) dbvars = 0 @@ -317,17 +284,14 @@ contains ! Partial densities if ((model_eqns == 2) .or. (model_eqns == 3)) then do i = 1, num_fluids - if (alpha_rho_wrt(i) & - .or. & - (cons_vars_wrt .or. prim_vars_wrt)) then + if (alpha_rho_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then dbvars = dbvars + 1 end if end do end if ! Density - if ((rho_wrt .or. (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) & - .and. (.not. relativity)) then + if ((rho_wrt .or. (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) .and. (.not. relativity)) then dbvars = dbvars + 1 end if @@ -375,29 +339,19 @@ contains ! Volume fraction(s) if ((model_eqns == 2) .or. (model_eqns == 3)) then - do i = 1, num_fluids - 1 - if (alpha_wrt(i) & - .or. & - (cons_vars_wrt .or. prim_vars_wrt)) then + if (alpha_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then dbvars = dbvars + 1 end if end do - if (alpha_wrt(num_fluids) & - .or. & - (cons_vars_wrt .or. prim_vars_wrt)) & - then + if (alpha_wrt(num_fluids) .or. (cons_vars_wrt .or. prim_vars_wrt)) then dbvars = dbvars + 1 end if - end if ! Specific heat ratio function - if (gamma_wrt & - .or. & - (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) & - then + if (gamma_wrt .or. (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) then dbvars = dbvars + 1 end if @@ -405,10 +359,7 @@ contains if (heat_ratio_wrt) dbvars = dbvars + 1 ! Liquid stiffness function - if (pi_inf_wrt & - .or. & - (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) & - then + if (pi_inf_wrt .or. (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) then dbvars = dbvars + 1 end if @@ -423,7 +374,7 @@ contains do i = 1, num_vels if (omega_wrt(i)) dbvars = dbvars + 1 end do - elseif (n > 0) then + else if (n > 0) then do i = 1, num_vels if (omega_wrt(i)) dbvars = dbvars + 1 end do @@ -431,25 +382,20 @@ contains ! Numerical Schlieren function if (schlieren_wrt) dbvars = dbvars + 1 - end if ! END: Querying Number of Flow Variable(s) in Binary Output - end subroutine s_initialize_data_output_module - !> @brief Compute the cell-index bounds for the user-specified partial output domain in each coordinate direction. impure subroutine s_define_output_region - integer :: i integer :: lower_bound, upper_bound #:for X, M in [('x', 'm'), ('y', 'n'), ('z', 'p')] - if (${M}$ == 0) return ! Early return for y or z if simulation is 1D or 2D lower_bound = -offset_${X}$%beg - upper_bound = ${M}$+offset_${X}$%end + upper_bound = ${M}$ + offset_${X}$%end do i = lower_bound, upper_bound if (${X}$_cc(i) > ${X}$_output%beg) then @@ -470,11 +416,8 @@ contains ${X}$_output_idx%beg = 0 ${X}$_output_idx%end = 0 end if - #:endfor - end subroutine s_define_output_region - !> @brief Open (or create) the Silo-HDF5 or Binary formatted database slave and master files for a given time step. impure subroutine s_open_formatted_database_file(t_step) ! Description: This subroutine opens a new formatted database file, or @@ -489,77 +432,63 @@ contains ! not performed in multidimensions. ! Time-step that is currently being post-processed - integer, intent(IN) :: t_step + integer, intent(in) :: t_step ! Generic string used to store the location of a particular file character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc - - integer :: ierr !< Generic flag used to identify and report database errors + integer :: ierr !< Generic flag used to identify and report database errors ! Silo-HDF5 Database Format if (format == 1) then - ! Generating the relative path to the formatted database slave ! file, that is to be opened for the current time-step, t_step write (file_loc, '(A,I0,A)') '/', t_step, '.silo' - file_loc = trim(proc_rank_dir)//trim(file_loc) + file_loc = trim(proc_rank_dir) // trim(file_loc) ! Creating formatted database slave file at the above location ! and setting up the structure of the file and its header info - 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, dbfile) ! Verifying that the creation and setup process of the formatted ! database slave file has been performed without errors. If this ! is not the case, the post-process exits. if (dbfile == -1) then - call s_mpi_abort('Unable to create Silo-HDF5 database '// & - 'slave file '//trim(file_loc)//'. '// & - 'Exiting.') + call s_mpi_abort('Unable to create Silo-HDF5 database ' // 'slave file ' // trim(file_loc) // '. ' // 'Exiting.') end if ! Next, analogous steps to the ones above are carried out by the ! root process to create and setup the formatted database master ! file. 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(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, dbroot) if (dbroot == -1) then - call s_mpi_abort('Unable to create Silo-HDF5 database '// & - 'master file '//trim(file_loc)//'. '// & - 'Exiting.') + call s_mpi_abort('Unable to create Silo-HDF5 database ' // 'master file ' // trim(file_loc) // '. ' & + & // 'Exiting.') end if - end if ! Binary Database Format - else ! Generating the relative path to the formatted database slave ! file, that is to be opened for the current time-step, t_step write (file_loc, '(A,I0,A)') '/', t_step, '.dat' - file_loc = trim(proc_rank_dir)//trim(file_loc) + file_loc = trim(proc_rank_dir) // trim(file_loc) ! Creating the formatted database slave file, at the previously ! precised relative path location, and setting up its structure - open (dbfile, IOSTAT=err, FILE=trim(file_loc), & - FORM='unformatted', STATUS='replace') + open (dbfile, IOSTAT=err, FILE=trim(file_loc), form='unformatted', STATUS='replace') ! Verifying that the creation and setup process of the formatted ! database slave file has been performed without errors. If this ! is not the case, the post-process exits. if (err /= 0) then - call s_mpi_abort('Unable to create Binary database slave '// & - 'file '//trim(file_loc)//'. Exiting.') + call s_mpi_abort('Unable to create Binary database slave ' // 'file ' // trim(file_loc) // '. Exiting.') end if ! Further defining the structure of the formatted database slave @@ -567,10 +496,8 @@ contains ! data as well as the total number of flow variable(s) that will ! eventually be stored in it 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 (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 else write (dbfile) m, n, p, dbvars end if @@ -579,17 +506,13 @@ contains ! root process to create and setup the formatted database master ! file. Note that this is only done in multidimensional cases. 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(rootdir) // trim(file_loc) - open (dbroot, IOSTAT=err, FILE=trim(file_loc), & - FORM='unformatted', STATUS='replace') + open (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.') + call s_mpi_abort('Unable to create Binary database ' // 'master file ' // trim(file_loc) // '. Exiting.') end if if (output_partial_domain) then @@ -597,47 +520,31 @@ contains else write (dbroot) m_root, 0, 0, dbvars end if - end if - end if - end subroutine s_open_formatted_database_file - !> @brief Open the interface data file for appending extracted interface coordinates. impure subroutine s_open_intf_data_file() - character(LEN=path_len + 3*name_len) :: file_path !< !! Relative path to a file in the case directory write (file_path, '(A)') '/intf_data.dat' - file_path = trim(case_dir)//trim(file_path) + file_path = trim(case_dir) // trim(file_path) ! Opening the simulation data file - open (211, FILE=trim(file_path), & - FORM='formatted', & - POSITION='append', & - STATUS='unknown') - + open (211, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') end subroutine s_open_intf_data_file - !> @brief Open the energy data file for appending volume-integrated energy budget quantities. impure subroutine s_open_energy_data_file() - character(LEN=path_len + 3*name_len) :: file_path !< !! Relative path to a file in the case directory write (file_path, '(A)') '/eng_data.dat' - file_path = trim(case_dir)//trim(file_path) + file_path = trim(case_dir) // trim(file_path) ! Opening the simulation data file - open (251, FILE=trim(file_path), & - FORM='formatted', & - POSITION='append', & - STATUS='unknown') - + open (251, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') end subroutine s_open_energy_data_file - !> @brief Write the computational grid (cell-boundary coordinates) to the formatted database slave and master files. impure subroutine s_write_grid_to_formatted_database_file(t_step) ! Description: The general objective of this subroutine is to write the @@ -658,45 +565,37 @@ contains ! flow variable data. Then, in this case, we take care of ! writing both the grid and the flow variable data in the ! subroutine s_write_variable_to_formatted_database_file. - ! Time-step that is currently being post-processed - integer, intent(IN) :: t_step + integer, intent(in) :: t_step ! Bookkeeping variables storing the name and type of mesh that is ! handled by the local processor(s). Note that due to an internal ! NAG Fortran compiler problem, these two variables could not be ! allocated dynamically. character(LEN=4*name_len), dimension(num_procs) :: meshnames - integer, dimension(num_procs) :: meshtypes + integer, dimension(num_procs) :: meshtypes ! Generic loop iterator integer :: i - integer :: ierr !< Generic flag used to identify and report database errors ! Silo-HDF5 Database Format if (format == 1) then - ! 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) - elseif (p > 0) then + 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)/) + 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)/) + spatial_extents(:, 0) = (/minval(x_cb), minval(y_cb), minval(z_cb), maxval(x_cb), maxval(y_cb), maxval(z_cb)/) end if - elseif (n > 0) then - spatial_extents(:, 0) = (/minval(x_cb), minval(y_cb), & - maxval(x_cb), maxval(y_cb)/) + else if (n > 0) then + 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)/) end if @@ -706,25 +605,19 @@ contains ! also records a sub-domain connectivity map so that the entire ! grid may be reassembled by looking at the master file. if (proc_rank == 0) then - do i = 1, num_procs - write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, & - '/', t_step, '.silo:rectilinear_grid' + write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:rectilinear_grid' end do meshtypes = DB_QUAD_RECT err = DBSET2DSTRLEN(len(meshnames(1))) err = DBMKOPTLIST(2, optlist) - err = DBADDIOPT(optlist, DBOPT_EXTENTS_SIZE, & - size(spatial_extents, 1)) + 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 = DBPUTMMESH(dbroot, 'rectilinear_grid', 16, num_procs, meshnames, len_trim(meshnames), meshtypes, optlist, & + & ierr) err = DBFREEOPTLIST(optlist) - end if ! Finally, the local quadrilateral mesh, either 2D or 3D, along @@ -736,72 +629,52 @@ contains err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) err = DBADDIOPT(optlist, DBOPT_HI_OFFSET, 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(dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, y_cb, z_cb, x_cb, dims, 3, DB_DOUBLE, & + & DB_COLLINEAR, 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(dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, x_cb, y_cb, z_cb, dims, 3, DB_DOUBLE, & + & DB_COLLINEAR, optlist, ierr) end if err = DBFREEOPTLIST(optlist) - elseif (n > 0) then + else if (n > 0) then err = DBMKOPTLIST(2, optlist) err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) err = DBADDIOPT(optlist, DBOPT_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 = 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) else err = DBMKOPTLIST(2, optlist) err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) err = DBADDIOPT(optlist, DBOPT_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 = 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) end if ! END: Silo-HDF5 Database Format ! Binary Database Format - - elseif (format == 2) then - + else if (format == 2) 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 == 1) then - write (dbfile) real(x_cb, sp), & - real(y_cb, sp), & - real(z_cb, sp) + write (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 (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 end if end if - - elseif (n > 0) then + else if (n > 0) then if (precision == 1) then - write (dbfile) real(x_cb, sp), & - real(y_cb, sp) + write (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 (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 end if @@ -839,13 +712,9 @@ contains end if end if end if - end if - end if - end subroutine s_write_grid_to_formatted_database_file - !> @brief Write a single flow variable field to the formatted database slave and master files for a given time step. impure subroutine s_write_variable_to_formatted_database_file(varname, t_step) ! Description: The goal of this subroutine is to write to the formatted @@ -866,27 +735,25 @@ contains ! Name of the flow variable, which will be written to the formatted ! database file at the current time-step, t_step - character(LEN=*), intent(IN) :: varname + character(LEN=*), intent(in) :: varname ! Time-step that is currently being post-processed - integer, intent(IN) :: t_step + integer, intent(in) :: t_step ! Bookkeeping variables storing the name and type of flow variable ! that is about to be handled by the local processor(s). Note that ! due to an internal NAG Fortran compiler problem, these variables ! could not be allocated dynamically. character(LEN=4*name_len), dimension(num_procs) :: varnames - integer, dimension(num_procs) :: vartypes + integer, dimension(num_procs) :: vartypes ! Generic loop iterator integer :: i, j, k - integer :: ierr !< Generic flag used to identify and report database errors ! Silo-HDF5 Database Format if (format == 1) 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 @@ -898,10 +765,8 @@ contains ! Next, the root process proceeds to write the gathered flow ! variable data extents to formatted database master file. if (proc_rank == 0) then - do i = 1, num_procs - write (varnames(i), '(A,I0,A,I0,A)') '../p', i - 1, & - '/', t_step, '.silo:'//trim(varname) + write (varnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:' // trim(varname) end do vartypes = DB_QUADVAR @@ -910,12 +775,9 @@ contains 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 = DBPUTMVAR(dbroot, trim(varname), len_trim(varname), num_procs, varnames, len_trim(varnames), vartypes, & + & optlist, ierr) err = DBFREEOPTLIST(optlist) - end if ! Finally, each of the local processor(s) proceeds to write @@ -950,7 +812,7 @@ contains end do end if end if - elseif (wp == sp) then + else if (wp == sp) then 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 @@ -973,35 +835,18 @@ 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(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) 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(dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, q_sf${SFX}$, & + & dims - 1, 3, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) end if - elseif (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) + 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) 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(dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, q_sf${SFX}$, dims - 1, & + & 1, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) end if end if #:endfor @@ -1009,7 +854,6 @@ contains ! END: Silo-HDF5 Database Format ! Binary Database Format - else ! Writing the name of the flow variable and its data, associated @@ -1024,11 +868,10 @@ contains ! 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) else - q_root_sf(:, :, :) = q_sf(:, :, :) + q_root_sf(:,:,:) = q_sf(:,:,:) end if if (proc_rank == 0) then @@ -1038,58 +881,47 @@ contains write (dbroot) varname, q_root_sf end if end if - end if - end if - end subroutine s_write_variable_to_formatted_database_file - - !> Subroutine that writes the post processed results in the folder 'lag_bubbles_data' - !! @param t_step Current time step + !> Subroutine that writes the post processed results in the folder 'lag_bubbles_data' + !! @param t_step Current time step impure subroutine s_write_lag_bubbles_results_to_text(t_step) - - integer, intent(in) :: t_step - + integer, intent(in) :: t_step character(len=len_trim(case_dir) + 3*name_len) :: file_loc - - integer :: id + integer :: id #ifdef MFC_MPI - real(wp), dimension(20) :: inputvals - real(wp) :: time_real - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer :: view - - logical :: lg_bub_file, file_exist - - integer, dimension(2) :: gsizes, lsizes, start_idx_part - integer :: ifile - integer :: ierr !< Generic flag used to identify and report MPI errors - real(wp) :: file_time, file_dt - integer :: file_num_procs, file_tot_part, tot_part - integer :: i - - integer, dimension(:), allocatable :: proc_bubble_counts + real(wp), dimension(20) :: inputvals + real(wp) :: time_real + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer :: view + logical :: lg_bub_file, file_exist + integer, dimension(2) :: gsizes, lsizes, start_idx_part + integer :: ifile + integer :: ierr !< Generic flag used to identify and report MPI errors + real(wp) :: file_time, file_dt + integer :: file_num_procs, file_tot_part, tot_part + integer :: i + integer, dimension(:), allocatable :: proc_bubble_counts real(wp), dimension(1:1, 1:lag_io_vars) :: lag_io_null lag_io_null = 0._wp ! Construct file path write (file_loc, '(A,I0,A)') 'lag_bubbles_', t_step, '.dat' - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) ! Check if file exists inquire (FILE=trim(file_loc), EXIST=file_exist) if (.not. file_exist) then - call s_mpi_abort('Restart file '//trim(file_loc)//' does not exist!') + call s_mpi_abort('Restart file ' // trim(file_loc) // ' does not exist!') end if if (.not. parallel_io) return if (proc_rank == 0) then - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) call MPI_FILE_READ(ifile, file_tot_part, 1, MPI_INTEGER, status, ierr) call MPI_FILE_READ(ifile, file_time, 1, mpi_p, status, ierr) @@ -1108,12 +940,10 @@ contains allocate (proc_bubble_counts(file_num_procs)) if (proc_rank == 0) then - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) ! Skip to processor counts position - disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs), & - MPI_OFFSET_KIND) + disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs), MPI_OFFSET_KIND) call MPI_FILE_SEEK(ifile, disp, MPI_SEEK_SET, ierr) call MPI_FILE_READ(ifile, proc_bubble_counts, file_num_procs, MPI_INTEGER, status, ierr) @@ -1129,25 +959,21 @@ contains start_idx_part(1) = 0 start_idx_part(2) = 0 - call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, & - MPI_ORDER_FORTRAN, mpi_p, view, ierr) + call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, MPI_ORDER_FORTRAN, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) + & - file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, & - 'native', mpi_info_null, ierr) + disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_null, ierr) allocate (MPI_IO_DATA_lg_bubbles(file_tot_part, 1:lag_io_vars)) - call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lg_bubbles, lag_io_vars*file_tot_part, & - mpi_p, status, ierr) + call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lg_bubbles, lag_io_vars*file_tot_part, mpi_p, status, ierr) write (file_loc, '(A,I0,A)') 'lag_bubbles_post_process_', t_step, '.dat' - file_loc = trim(case_dir)//'/lag_bubbles_post_process/'//trim(file_loc) + file_loc = trim(case_dir) // '/lag_bubbles_post_process/' // trim(file_loc) if (proc_rank == 0) then open (unit=29, file=file_loc, form='formatted', position='rewind') @@ -1178,9 +1004,12 @@ contains if (id > 0) then write (29, '(100(A))', advance='no') '' if (lag_id_wrt) write (29, '(I6, A)', advance='no') id, ', ' - if (lag_pos_wrt) write (29, '(3(E15.7, A))', advance='no') inputvals(1), ', ', inputvals(2), ', ', inputvals(3), ', ' - if (lag_pos_prev_wrt) write (29, '(3(E15.7, A))', advance='no') inputvals(4), ', ', inputvals(5), ', ', inputvals(6), ', ' - if (lag_vel_wrt) write (29, '(3(E15.7, A))', advance='no') inputvals(7), ', ', inputvals(8), ', ', inputvals(9), ', ' + if (lag_pos_wrt) write (29, '(3(E15.7, A))', advance='no') inputvals(1), ', ', inputvals(2), ', ', & + & inputvals(3), ', ' + if (lag_pos_prev_wrt) write (29, '(3(E15.7, A))', advance='no') inputvals(4), ', ', inputvals(5), ', ', & + & inputvals(6), ', ' + if (lag_vel_wrt) write (29, '(3(E15.7, A))', advance='no') inputvals(7), ', ', inputvals(8), ', ', & + & inputvals(9), ', ' if (lag_rad_wrt) write (29, '(E15.7, A)', advance='no') inputvals(10), ', ' if (lag_rvel_wrt) write (29, '(E15.7, A)', advance='no') inputvals(11), ', ' if (lag_r0_wrt) write (29, '(E15.7, A)', advance='no') inputvals(12), ', ' @@ -1204,62 +1033,52 @@ contains call MPI_FILE_CLOSE(ifile, ierr) #endif - end subroutine s_write_lag_bubbles_results_to_text - !> @brief Read Lagrangian bubble restart data and write bubble positions and scalar fields to the Silo database. impure subroutine s_write_lag_bubbles_to_formatted_database_file(t_step) - - integer, intent(in) :: t_step - + integer, intent(in) :: t_step character(len=len_trim(case_dir) + 3*name_len) :: file_loc - - integer :: id + integer :: id #ifdef MFC_MPI - real(wp), dimension(20) :: inputvals - real(wp) :: time_real - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer :: view - - logical :: lg_bub_file, file_exist - - integer, dimension(2) :: gsizes, lsizes, start_idx_part - integer :: ifile, ierr, tot_data, valid_data, nBub - real(wp) :: file_time, file_dt - integer :: file_num_procs, file_tot_part - integer, dimension(:), allocatable :: proc_bubble_counts - real(wp), dimension(1:1, 1:lag_io_vars) :: dummy + real(wp), dimension(20) :: inputvals + real(wp) :: time_real + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer :: view + logical :: lg_bub_file, file_exist + integer, dimension(2) :: gsizes, lsizes, start_idx_part + integer :: ifile, ierr, tot_data, valid_data, nBub + real(wp) :: file_time, file_dt + integer :: file_num_procs, file_tot_part + integer, dimension(:), allocatable :: proc_bubble_counts + real(wp), dimension(1:1, 1:lag_io_vars) :: dummy character(LEN=4*name_len), dimension(num_procs) :: meshnames - integer, dimension(num_procs) :: meshtypes - real(wp) :: dummy_data - - integer :: i, j - - real(wp), dimension(:), allocatable :: bub_id - real(wp), dimension(:), allocatable :: px, py, pz, ppx, ppy, ppz, vx, vy, vz - real(wp), dimension(:), allocatable :: radius, rvel, rnot, rmax, rmin, dphidt - real(wp), dimension(:), allocatable :: pressure, mv, mg, betaT, betaC + integer, dimension(num_procs) :: meshtypes + real(wp) :: dummy_data + integer :: i, j + real(wp), dimension(:), allocatable :: bub_id + real(wp), dimension(:), allocatable :: px, py, pz, ppx, ppy, ppz, vx, vy, vz + real(wp), dimension(:), allocatable :: radius, rvel, rnot, rmax, rmin, dphidt + real(wp), dimension(:), allocatable :: pressure, mv, mg, betaT, betaC dummy = 0._wp dummy_data = 0._wp ! Construct file path write (file_loc, '(A,I0,A)') 'lag_bubbles_', t_step, '.dat' - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) ! Check if file exists inquire (FILE=trim(file_loc), EXIST=file_exist) if (.not. file_exist) then - call s_mpi_abort('Restart file '//trim(file_loc)//' does not exist!') + call s_mpi_abort('Restart file ' // trim(file_loc) // ' does not exist!') end if if (.not. parallel_io) return if (proc_rank == 0) then - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) call MPI_FILE_READ(ifile, file_tot_part, 1, MPI_INTEGER, status, ierr) call MPI_FILE_READ(ifile, file_time, 1, mpi_p, status, ierr) @@ -1278,12 +1097,10 @@ contains allocate (proc_bubble_counts(file_num_procs)) if (proc_rank == 0) then - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) ! Skip to processor counts position - disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs), & - MPI_OFFSET_KIND) + disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs), MPI_OFFSET_KIND) call MPI_FILE_SEEK(ifile, disp, MPI_SEEK_SET, ierr) call MPI_FILE_READ(ifile, proc_bubble_counts, file_num_procs, MPI_INTEGER, status, ierr) @@ -1309,7 +1126,6 @@ contains gsizes(2) = lag_io_vars if (nBub > 0) then - #:for VAR in ['bub_id', 'px', 'py', 'pz', 'ppx', 'ppy', 'ppz', 'vx', 'vy', 'vz', & 'radius', 'rvel', 'rnot', 'rmax', 'rmin', 'dphidt', & 'pressure', 'mv', 'mg', 'betaT', 'betaC'] @@ -1317,20 +1133,17 @@ contains #:endfor allocate (MPI_IO_DATA_lg_bubbles(nBub, 1:lag_io_vars)) - call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, & - MPI_ORDER_FORTRAN, mpi_p, view, ierr) + call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, MPI_ORDER_FORTRAN, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) ! Skip extended header - disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) + & - file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) - call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lg_bubbles, & - lag_io_vars*nBub, mpi_p, status, ierr) + call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lg_bubbles, lag_io_vars*nBub, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) call MPI_TYPE_FREE(view, ierr) @@ -1349,22 +1162,15 @@ contains ! also records a sub-domain connectivity map so that the entire ! grid may be reassembled by looking at the master file. if (proc_rank == 0) then - do i = 1, num_procs - write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, & - '/', t_step, '.silo:lag_bubbles' + write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:lag_bubbles' 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(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(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 @@ -1384,20 +1190,18 @@ contains if (lag_betaT_wrt) call s_write_lag_variable_to_formatted_database_file('part_betaT', t_step, betaT, nBub) if (lag_betaC_wrt) call s_write_lag_variable_to_formatted_database_file('part_betaC', t_step, betaC, nBub) - deallocate (bub_id, px, py, pz, ppx, ppy, ppz, vx, vy, vz, radius, & - rvel, rnot, rmax, rmin, dphidt, pressure, mv, mg, & - betaT, betaC) + deallocate (bub_id, px, py, pz, ppx, ppy, ppz, vx, vy, vz, radius, rvel, rnot, rmax, rmin, dphidt, pressure, mv, mg, & + & betaT, betaC) deallocate (MPI_IO_DATA_lg_bubbles) else call MPI_TYPE_CONTIGUOUS(0, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) ! Skip extended header - disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) + & - file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -1406,23 +1210,16 @@ contains call MPI_TYPE_FREE(view, ierr) if (proc_rank == 0) then - do i = 1, num_procs - write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, & - '/', t_step, '.silo:lag_bubbles' + write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:lag_bubbles' 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(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(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 @@ -1442,110 +1239,88 @@ contains if (lag_betaT_wrt) call s_write_lag_variable_to_formatted_database_file('part_betaT', t_step) if (lag_betaC_wrt) call s_write_lag_variable_to_formatted_database_file('part_betaC', t_step) end if - #endif - end subroutine s_write_lag_bubbles_to_formatted_database_file - !> @brief Write a single Lagrangian bubble point-variable to the Silo database slave and master files. subroutine s_write_lag_variable_to_formatted_database_file(varname, t_step, data, nBubs) - - character(len=*), intent(in) :: varname - integer, intent(in) :: t_step + character(len=*), intent(in) :: varname + integer, intent(in) :: t_step real(wp), dimension(1:), intent(in), optional :: data - integer, intent(in), optional :: nBubs - - character(len=64), dimension(num_procs) :: var_names - integer, dimension(num_procs) :: var_types - real(wp) :: dummy_data - - integer :: ierr !< Generic flag used to identify and report database errors - integer :: i + integer, intent(in), optional :: nBubs + character(len=64), dimension(num_procs) :: var_names + integer, dimension(num_procs) :: var_types + real(wp) :: dummy_data + integer :: ierr !< Generic flag used to identify and report database errors + integer :: i dummy_data = 0._wp if (present(nBubs) .and. present(data)) then if (proc_rank == 0) then do i = 1, num_procs - write (var_names(i), '(A,I0,A,I0,A)') '../p', i - 1, & - '/', t_step, '.silo:'//trim(varname) + write (var_names(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:' // trim(varname) 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(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(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 - write (var_names(i), '(A,I0,A,I0,A)') '../p', i - 1, & - '/', t_step, '.silo:'//trim(varname) + write (var_names(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:' // trim(varname) var_types(i) = DB_POINTVAR 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(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(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 - impure subroutine s_write_ib_state_files() - character(len=len_trim(case_dir) + 4*name_len) :: in_file, out_file, file_loc - integer :: iu_in, ios, i, rec_id - integer, allocatable, dimension(:) :: iu_out - real(wp) :: rec_time - real(wp), dimension(3) :: rec_force, rec_torque - real(wp), dimension(3) :: rec_vel, rec_angular_vel - real(wp), dimension(3) :: rec_angles, rec_centroid - - file_loc = trim(case_dir)//'/D' - - in_file = trim(file_loc)//'/ib_state.dat' - open (newunit=iu_in, file=trim(in_file), form='unformatted', access='stream', & - status='old', action='read', iostat=ios) + integer :: iu_in, ios, i, rec_id + integer, allocatable, dimension(:) :: iu_out + real(wp) :: rec_time + real(wp), dimension(3) :: rec_force, rec_torque + real(wp), dimension(3) :: rec_vel, rec_angular_vel + real(wp), dimension(3) :: rec_angles, rec_centroid + + file_loc = trim(case_dir) // '/D' + + in_file = trim(file_loc) // '/ib_state.dat' + open (newunit=iu_in, file=trim(in_file), form='unformatted', access='stream', status='old', action='read', iostat=ios) if (ios /= 0) then - call s_mpi_abort('Cannot open IB state input file: '//trim(in_file)) + call s_mpi_abort('Cannot open IB state input file: ' // trim(in_file)) end if allocate (iu_out(num_ibs)) do i = 1, num_ibs - write (out_file, '(A,I0,A)') trim(file_loc)//'/ib_', i, '.txt' + write (out_file, '(A,I0,A)') trim(file_loc) // '/ib_', i, '.txt' open (newunit=iu_out(i), file=trim(out_file), form='formatted', status='replace', action='write', iostat=ios) if (ios /= 0) then - call s_mpi_abort('Cannot open IB state output file: '//trim(out_file)) + call s_mpi_abort('Cannot open IB state output file: ' // trim(out_file)) end if - write (iu_out(i), '(A)') & - 'mytime fx fy fz Tau_x Tau_y Tau_z vx vy vz omega_x omega_y omega_z angle_x angle_y angle_z x_c y_c z_c' + write (iu_out(i), & + & '(A)') 'mytime fx fy fz Tau_x Tau_y Tau_z vx vy vz omega_x omega_y omega_z angle_x angle_y angle_z x_c y_c z_c' end do do - read (iu_in, iostat=ios) rec_time, rec_id, & - rec_force, rec_torque, rec_vel, rec_angular_vel, rec_angles, & - rec_centroid(1), rec_centroid(2), rec_centroid(3) + read (iu_in, iostat=ios) rec_time, rec_id, rec_force, rec_torque, rec_vel, rec_angular_vel, rec_angles, & + & rec_centroid(1), rec_centroid(2), rec_centroid(3) if (ios /= 0) exit if (rec_id >= 1 .and. rec_id <= num_ibs) then - write (iu_out(rec_id), '(19(ES24.16E3,1X))') rec_time, & - rec_force(1), rec_force(2), rec_force(3), & - rec_torque(1), rec_torque(2), rec_torque(3), & - rec_vel(1), rec_vel(2), rec_vel(3), & - rec_angular_vel(1), rec_angular_vel(2), rec_angular_vel(3), & - rec_angles(1), rec_angles(2), rec_angles(3), & - rec_centroid(1), rec_centroid(2), rec_centroid(3) + write (iu_out(rec_id), '(19(ES24.16E3,1X))') rec_time, rec_force(1), rec_force(2), rec_force(3), rec_torque(1), & + & rec_torque(2), rec_torque(3), rec_vel(1), rec_vel(2), rec_vel(3), rec_angular_vel(1), & + & rec_angular_vel(2), rec_angular_vel(3), rec_angles(1), rec_angles(2), rec_angles(3), rec_centroid(1), & + & rec_centroid(2), rec_centroid(3) end if end do @@ -1554,17 +1329,15 @@ contains close (iu_out(i)) end do deallocate (iu_out) - end subroutine s_write_ib_state_files - - !> @brief Extract the volume-fraction interface contour from primitive fields and write the coordinates to the interface data file. + !> @brief Extract the volume-fraction interface contour from primitive fields and write the coordinates to the interface data + !! file. impure subroutine s_write_intf_data_file(q_prim_vf) - - type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf - integer :: i, j, k, l, cent !< Generic loop iterators - integer :: counter, root !< number of data points extracted to fit shape to SH perturbations - real(wp), allocatable :: x_td(:), y_td(:), x_d1(:), y_d1(:), y_d(:), x_d(:) - real(wp) :: axp, axm, ayp, aym, tgp, euc_d, thres, maxalph_loc, maxalph_glb + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + integer :: i, j, k, l, cent !< Generic loop iterators + integer :: counter, root !< number of data points extracted to fit shape to SH perturbations + real(wp), allocatable :: x_td(:), y_td(:), x_d1(:), y_d1(:), y_d(:), x_d(:) + real(wp) :: axp, axm, ayp, aym, tgp, euc_d, thres, maxalph_loc, maxalph_glb allocate (x_d1(m*n)) allocate (y_d1(m*n)) @@ -1598,8 +1371,8 @@ contains axm = q_prim_vf(E_idx + 2)%sf(j, k, cent) ayp = q_prim_vf(E_idx + 2)%sf(j, k + 1, cent) aym = q_prim_vf(E_idx + 2)%sf(j, k, cent) - if ((axp > thres .and. axm < thres) .or. (axp < thres .and. axm > thres) & - .or. (ayp > thres .and. aym < thres) .or. (ayp < thres .and. aym > thres)) then + if ((axp > thres .and. axm < thres) .or. (axp < thres .and. axm > thres) .or. (ayp > thres .and. aym < thres) & + & .or. (ayp < thres .and. aym > thres)) then if (counter == 0) then counter = counter + 1 x_d1(counter) = x_cc(j) @@ -1610,7 +1383,7 @@ contains euc_d = sqrt((x_cc(j) - x_d1(i))**2 + (y_cc(k) - y_d1(i))**2) if (euc_d < tgp) then exit - elseif (i == counter) then + else if (i == counter) then counter = counter + 1 x_d1(counter) = x_cc(j) y_d1(counter) = y_cc(k) @@ -1634,25 +1407,22 @@ contains if (proc_rank == 0) then do i = 1, size(x_td) if (i == size(x_td)) then - write (211, '(F12.9,1X,F12.9,1X,I4)') & - x_td(i), y_td(i), size(x_td) + write (211, '(F12.9,1X,F12.9,1X,I4)') x_td(i), y_td(i), size(x_td) else - write (211, '(F12.9,1X,F12.9,1X,F3.1)') & - x_td(i), y_td(i), 0._wp + write (211, '(F12.9,1X,F12.9,1X,F3.1)') x_td(i), y_td(i), 0._wp end if end do end if - end subroutine s_write_intf_data_file - - !> @brief Compute volume-integrated kinetic, potential, and internal energies and write the energy budget to the energy data file. + !> @brief Compute volume-integrated kinetic, potential, and internal energies and write the energy budget to the energy data + !! file. impure subroutine s_write_energy_data_file(q_prim_vf, q_cons_vf) - type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf, q_cons_vf - real(wp) :: Elk, Egk, Elp, Egint, Vb, Vl, pres_av, Et - real(wp) :: rho, pres, dV, tmp, gamma, pi_inf, MaxMa, MaxMa_glb, maxvel, c, Ma, H, qv - real(wp), dimension(num_vels) :: vel - real(wp), dimension(num_fluids) :: adv - integer :: i, j, k, l, s !looping indices + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf, q_cons_vf + real(wp) :: Elk, Egk, Elp, Egint, Vb, Vl, pres_av, Et + real(wp) :: rho, pres, dV, tmp, gamma, pi_inf, MaxMa, MaxMa_glb, maxvel, c, Ma, H, qv + real(wp), dimension(num_vels) :: vel + real(wp), dimension(num_fluids) :: adv + integer :: i, j, k, l, s ! looping indices Egk = 0._wp Elp = 0._wp @@ -1698,9 +1468,7 @@ contains H = ((gamma + 1._wp)*pres + pi_inf + qv)/rho - call s_compute_speed_of_sound(pres, rho, & - gamma, pi_inf, & - H, adv, 0._wp, 0._wp, c, qv) + call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, 0._wp, 0._wp, c, qv) Ma = maxvel/c if (Ma > MaxMa .and. (adv(1) > (1.0_wp - 1.0e-10_wp))) then @@ -1733,19 +1501,9 @@ contains Elp = pres_av/Vl*Vb if (proc_rank == 0) then - write (251, '(10X, 8F24.8)') & - Elp, & - Egint, & - Elk, & - Egk, & - Et, & - Vb, & - Vl, & - MaxMa_glb + write (251, '(10X, 8F24.8)') Elp, Egint, Elk, Egk, Et, Vb, Vl, MaxMa_glb end if - end subroutine s_write_energy_data_file - !> @brief Close the formatted database slave file and, for the root process, the master file. impure subroutine s_close_formatted_database_file() ! Description: The purpose of this subroutine is to close any formatted @@ -1771,25 +1529,16 @@ contains else close (dbfile) if (n == 0 .and. proc_rank == 0) close (dbroot) - end if - end subroutine s_close_formatted_database_file - !> @brief Close the interface data file. impure subroutine s_close_intf_data_file() - close (211) - end subroutine s_close_intf_data_file - !> @brief Close the energy data file. impure subroutine s_close_energy_data_file() - close (251) - end subroutine s_close_energy_data_file - !> @brief Deallocate module arrays and release all data-output resources. impure subroutine s_finalize_data_output_module() ! Description: Deallocation procedures for the module @@ -1814,7 +1563,5 @@ contains deallocate (hi_offset) deallocate (dims) end if - end subroutine s_finalize_data_output_module - end module m_data_output diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 0407d06485..48a236f917 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -5,7 +5,6 @@ !> @brief Computes derived flow quantities (sound speed, vorticity, Schlieren, etc.) from conservative and primitive variables module m_derived_variables - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code @@ -18,31 +17,22 @@ module m_derived_variables implicit none - 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 !< + 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 !< !! Gradient magnitude (gm) of the density for each cell of the computational !! sub-domain. This variable is employed in the calculation of the numerical !! Schlieren function. - !> @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. + !> @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 + real(wp), allocatable, dimension(:,:), public :: fd_coeff_x + real(wp), allocatable, dimension(:,:), public :: fd_coeff_y + real(wp), allocatable, dimension(:,:), public :: fd_coeff_z !> @} integer, private :: flg !< @@ -53,19 +43,14 @@ module m_derived_variables !! flow variable(s) when the simulation is not 3D and the size of the buffer !! is non-zero. Note that a similar procedure does not have to be applied to !! the second dimension since in 1D, the buffer size is always zero. - contains - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_derived_variables_module - ! Allocating the gradient magnitude of the density variable provided ! that numerical Schlieren function is outputted during post-process 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 (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 ! Allocating the variables which will store the coefficients of the @@ -78,24 +63,17 @@ contains ! Allocating centered finite-difference coefficients in x-direction 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_coeff_x(-fd_number:fd_number, -offset_x%beg:m + offset_x%end)) end if ! Allocating centered finite-difference coefficients in y-direction - 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)) + 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)) end if ! Allocating centered finite-difference coefficients in z-direction - 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)) + 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)) end if ! Annotating the dimensionality of the dataset undergoing the post- @@ -106,21 +84,13 @@ contains else flg = 0 end if - end subroutine s_initialize_derived_variables_module - - !> This subroutine receives as input the specific heat ratio - !! function, gamma_sf, and derives from it the specific heat - !! ratio. The latter is stored in the derived flow quantity - !! storage variable, q_sf. - !! @param q_sf Specific heat ratio + !> This subroutine receives as input the specific heat ratio function, gamma_sf, and derives from it the specific heat ratio. + !! The latter is stored in the derived flow quantity storage variable, q_sf. + !! @param q_sf Specific heat ratio subroutine s_derive_specific_heat_ratio(q_sf) - - real(wp), & - dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & - intent(inout) :: q_sf + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators @@ -132,22 +102,14 @@ contains end do end do end do - end subroutine s_derive_specific_heat_ratio - - !> This subroutine admits as inputs the specific heat ratio - !! function and the liquid stiffness function, gamma_sf and - !! pi_inf_sf, respectively. These are used to calculate the - !! values of the liquid stiffness, which are stored in the - !! derived flow quantity storage variable, q_sf. - !! @param q_sf Liquid stiffness + !> This subroutine admits as inputs the specific heat ratio function and the liquid stiffness function, gamma_sf and pi_inf_sf, + !! respectively. These are used to calculate the values of the liquid stiffness, which are stored in the derived flow quantity + !! storage variable, q_sf. + !! @param q_sf Liquid stiffness subroutine s_derive_liquid_stiffness(q_sf) - - real(wp), & - dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & - intent(inout) :: q_sf + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators @@ -160,27 +122,17 @@ contains end do end do end do - end subroutine s_derive_liquid_stiffness - - !> This subroutine admits as inputs the primitive variables, - !! the density, the specific heat ratio function and liquid - !! stiffness function. It then computes from those variables - !! the values of the speed of sound, which are stored in the - !! derived flow quantity storage variable, q_sf. + !> This subroutine admits as inputs the primitive variables, the density, the specific heat ratio function and liquid stiffness + !! function. It then computes from those variables the values of the speed of sound, which are stored in the derived flow + !! quantity storage variable, q_sf. !! @param q_prim_vf Primitive variables !! @param q_sf Speed of sound subroutine s_derive_sound_speed(q_prim_vf, q_sf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_prim_vf - - real(wp), & - dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & - intent(inout) :: q_sf + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators @@ -192,20 +144,15 @@ contains do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end - ! Compute mixture sound speed if (alt_soundspeed .neqv. .true.) then - q_sf(i, j, k) = (((gamma_sf(i, j, k) + 1._wp)* & - q_prim_vf(E_idx)%sf(i, j, k) + & - pi_inf_sf(i, j, k))/(gamma_sf(i, j, k)* & - rho_sf(i, j, k))) + q_sf(i, j, k) = (((gamma_sf(i, j, k) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_inf_sf(i, j, & + & k))/(gamma_sf(i, j, k)*rho_sf(i, j, k))) else - blkmod1 = ((gammas(1) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + & - pi_infs(1))/gammas(1) - blkmod2 = ((gammas(2) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + & - pi_infs(2))/gammas(2) - q_sf(i, j, k) = (1._wp/(rho_sf(i, j, k)*(q_prim_vf(adv_idx%beg)%sf(i, j, k)/blkmod1 + & - (1._wp - q_prim_vf(adv_idx%beg)%sf(i, j, k))/blkmod2))) + blkmod1 = ((gammas(1) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_infs(1))/gammas(1) + blkmod2 = ((gammas(2) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_infs(2))/gammas(2) + q_sf(i, j, k) = (1._wp/(rho_sf(i, j, k)*(q_prim_vf(adv_idx%beg)%sf(i, j, & + & k)/blkmod1 + (1._wp - q_prim_vf(adv_idx%beg)%sf(i, j, k))/blkmod2))) end if if (mixture_err .and. q_sf(i, j, k) < 0._wp) then @@ -216,69 +163,49 @@ contains end do end do end do - end subroutine s_derive_sound_speed - - !> This subroutine derives the flux_limiter at cell boundary - !! i+1/2. This is an approximation because the velocity used - !! to determine the upwind direction is the velocity at the - !! cell center i instead of the contact velocity at the cell - !! boundary from the Riemann solver. - !! @param i Component indicator - !! @param q_prim_vf Primitive variables - !! @param q_sf Flux limiter + !> This subroutine derives the flux_limiter at cell boundary i+1/2. This is an approximation because the velocity used to + !! determine the upwind direction is the velocity at the cell center i instead of the contact velocity at the cell boundary from + !! the Riemann solver. + !! @param i Component indicator + !! @param q_prim_vf Primitive variables + !! @param q_sf Flux limiter subroutine s_derive_flux_limiter(i, q_prim_vf, q_sf) - - integer, intent(in) :: i - + integer, intent(in) :: i type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & - intent(inout) :: q_sf + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + & intent(inout) :: q_sf real(wp) :: top, bottom, slope !< Flux limiter calcs - integer :: j, k, l !< Generic loop iterators + integer :: j, k, l !< Generic loop iterators do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end if (i == 1) then if (q_prim_vf(cont_idx%end + i)%sf(j, k, l) >= 0._wp) then - top = q_prim_vf(adv_idx%beg)%sf(j, k, l) - & - q_prim_vf(adv_idx%beg)%sf(j - 1, k, l) - bottom = q_prim_vf(adv_idx%beg)%sf(j + 1, k, l) - & - q_prim_vf(adv_idx%beg)%sf(j, k, l) + top = q_prim_vf(adv_idx%beg)%sf(j, k, l) - q_prim_vf(adv_idx%beg)%sf(j - 1, k, l) + bottom = q_prim_vf(adv_idx%beg)%sf(j + 1, k, l) - q_prim_vf(adv_idx%beg)%sf(j, k, l) else - top = q_prim_vf(adv_idx%beg)%sf(j + 2, k, l) - & - q_prim_vf(adv_idx%beg)%sf(j + 1, k, l) - bottom = q_prim_vf(adv_idx%beg)%sf(j + 1, k, l) - & - q_prim_vf(adv_idx%beg)%sf(j, k, l) + top = q_prim_vf(adv_idx%beg)%sf(j + 2, k, l) - q_prim_vf(adv_idx%beg)%sf(j + 1, k, l) + bottom = q_prim_vf(adv_idx%beg)%sf(j + 1, k, l) - q_prim_vf(adv_idx%beg)%sf(j, k, l) end if - elseif (i == 2) then + else if (i == 2) then if (q_prim_vf(cont_idx%end + i)%sf(j, k, l) >= 0._wp) then - top = q_prim_vf(adv_idx%beg)%sf(j, k, l) - & - q_prim_vf(adv_idx%beg)%sf(j, k - 1, l) - bottom = q_prim_vf(adv_idx%beg)%sf(j, k + 1, l) - & - q_prim_vf(adv_idx%beg)%sf(j, k, l) + top = q_prim_vf(adv_idx%beg)%sf(j, k, l) - q_prim_vf(adv_idx%beg)%sf(j, k - 1, l) + bottom = q_prim_vf(adv_idx%beg)%sf(j, k + 1, l) - q_prim_vf(adv_idx%beg)%sf(j, k, l) else - top = q_prim_vf(adv_idx%beg)%sf(j, k + 2, l) - & - q_prim_vf(adv_idx%beg)%sf(j, k + 1, l) - bottom = q_prim_vf(adv_idx%beg)%sf(j, k + 1, l) - & - q_prim_vf(adv_idx%beg)%sf(j, k, l) + top = q_prim_vf(adv_idx%beg)%sf(j, k + 2, l) - q_prim_vf(adv_idx%beg)%sf(j, k + 1, l) + bottom = q_prim_vf(adv_idx%beg)%sf(j, k + 1, l) - q_prim_vf(adv_idx%beg)%sf(j, k, l) end if else if (q_prim_vf(cont_idx%end + i)%sf(j, k, l) >= 0._wp) then - top = q_prim_vf(adv_idx%beg)%sf(j, k, l) - & - q_prim_vf(adv_idx%beg)%sf(j, k, l - 1) - bottom = q_prim_vf(adv_idx%beg)%sf(j, k, l + 1) - & - q_prim_vf(adv_idx%beg)%sf(j, k, l) + top = q_prim_vf(adv_idx%beg)%sf(j, k, l) - q_prim_vf(adv_idx%beg)%sf(j, k, l - 1) + bottom = q_prim_vf(adv_idx%beg)%sf(j, k, l + 1) - q_prim_vf(adv_idx%beg)%sf(j, k, l) else - top = q_prim_vf(adv_idx%beg)%sf(j, k, l + 2) - & - q_prim_vf(adv_idx%beg)%sf(j, k, l + 1) - bottom = q_prim_vf(adv_idx%beg)%sf(j, k, l + 1) - & - q_prim_vf(adv_idx%beg)%sf(j, k, l) + top = q_prim_vf(adv_idx%beg)%sf(j, k, l + 2) - q_prim_vf(adv_idx%beg)%sf(j, k, l + 1) + bottom = q_prim_vf(adv_idx%beg)%sf(j, k, l + 1) - q_prim_vf(adv_idx%beg)%sf(j, k, l) end if end if @@ -298,37 +225,35 @@ contains ! Flux limiter function if (flux_lim == 1) then ! MINMOD (MM) q_sf(j, k, l) = max(0._wp, min(1._wp, slope)) - elseif (flux_lim == 2) then ! MUSCL (MC) + else if (flux_lim == 2) then ! MUSCL (MC) q_sf(j, k, l) = max(0._wp, min(2._wp*slope, 5.e-1_wp*(1._wp + slope), 2._wp)) - elseif (flux_lim == 3) then ! OSPRE (OP) + else if (flux_lim == 3) then ! OSPRE (OP) q_sf(j, k, l) = (15.e-1_wp*(slope**2._wp + slope))/(slope**2._wp + slope + 1._wp) - elseif (flux_lim == 4) then ! SUPERBEE (SB) + else if (flux_lim == 4) then ! SUPERBEE (SB) q_sf(j, k, l) = max(0._wp, min(1._wp, 2._wp*slope), min(slope, 2._wp)) - elseif (flux_lim == 5) then ! SWEBY (SW) (beta = 1.5) + else if (flux_lim == 5) then ! SWEBY (SW) (beta = 1.5) q_sf(j, k, l) = max(0._wp, min(15.e-1_wp*slope, 1._wp), min(slope, 15.e-1_wp)) - elseif (flux_lim == 6) then ! VAN ALBADA (VA) + else if (flux_lim == 6) then ! VAN ALBADA (VA) q_sf(j, k, l) = (slope**2._wp + slope)/(slope**2._wp + 1._wp) - elseif (flux_lim == 7) then ! VAN LEER (VL) + else if (flux_lim == 7) then ! VAN LEER (VL) q_sf(j, k, l) = (abs(slope) + slope)/(1._wp + abs(slope)) end if end do end do end do end subroutine s_derive_flux_limiter - - !> Computes the solution to the linear system Ax=b w/ sol = x - !! @param A Input matrix - !! @param b right-hane-side - !! @param sol Solution - !! @param ndim Problem size + !> Computes the solution to the linear system Ax=b w/ sol = x + !! @param A Input matrix + !! @param b right-hane-side + !! @param sol Solution + !! @param ndim Problem size subroutine s_solve_linear_system(A, b, sol, ndim) - - integer, intent(in) :: ndim + integer, intent(in) :: ndim real(wp), dimension(ndim, ndim), intent(inout) :: A - real(wp), dimension(ndim), intent(inout) :: b - real(wp), dimension(ndim), intent(out) :: sol + real(wp), dimension(ndim), intent(inout) :: b + real(wp), dimension(ndim), intent(out) :: sol - !EXTERNAL DGESV + ! EXTERNAL DGESV integer :: i, j, k @@ -337,18 +262,18 @@ contains do i = 1, ndim ! Pivoting j = i - 1 + maxloc(abs(A(i:ndim, i)), 1) - sol = A(i, :) - A(i, :) = A(j, :) - A(j, :) = sol + sol = A(i,:) + A(i,:) = A(j,:) + A(j,:) = sol sol(1) = b(i) b(i) = b(j) b(j) = sol(1) ! Elimination b(i) = b(i)/A(i, i) - A(i, :) = A(i, :)/A(i, i) + A(i,:) = A(i,:)/A(i, i) do k = i + 1, ndim b(k) = b(k) - A(k, i)*b(i) - A(k, :) = A(k, :) - A(k, i)*A(i, :) + A(k,:) = A(k,:) - A(k, i)*A(i,:) end do end do @@ -359,31 +284,19 @@ contains sol(i) = sol(i) - A(i, k)*sol(k) end do end do - end subroutine s_solve_linear_system - - !> This subroutine receives as inputs the indicator of the - !! component of the vorticity that should be outputted and - !! the primitive variables. From those inputs, it proceeds - !! to calculate values of the desired vorticity component, - !! which are subsequently stored in derived flow quantity - !! storage variable, q_sf. - !! @param i Vorticity component indicator - !! @param q_prim_vf Primitive variables - !! @param q_sf Vorticity component + !> This subroutine receives as inputs the indicator of the component of the vorticity that should be outputted and the primitive + !! variables. From those inputs, it proceeds to calculate values of the desired vorticity component, which are subsequently + !! stored in derived flow quantity storage variable, q_sf. + !! @param i Vorticity component indicator + !! @param q_prim_vf Primitive variables + !! @param q_sf Vorticity component subroutine s_derive_vorticity_component(i, q_prim_vf, q_sf) + integer, intent(in) :: i + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer, intent(in) :: i - - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_prim_vf - - real(wp), & - dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & - intent(inout) :: q_sf + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + & intent(inout) :: q_sf integer :: j, k, l, r !< Generic loop iterators @@ -392,54 +305,38 @@ contains do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - q_sf(j, k, l) = 0._wp 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(mom_idx%end)%sf(j, r + k, l) & - - fd_coeff_z(r, l)* & - q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l)) + 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(mom_idx%end)%sf(j, r + k, l) - fd_coeff_z(r, & + & l)*q_prim_vf(mom_idx%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(mom_idx%end)%sf(j, r + k, l) & - - fd_coeff_z(r, l)* & - q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l) + q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_y(r, k)*q_prim_vf(mom_idx%end)%sf(j, r + k, & + & l) - fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l) end if end do - end do end do end do ! Computing the vorticity component in the y-coordinate direction - elseif (i == 2) then + else if (i == 2) then do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - q_sf(j, k, l) = 0._wp 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(mom_idx%beg)%sf(j, k, r + l) & - - fd_coeff_x(r, j)* & - q_prim_vf(mom_idx%end)%sf(r + j, k, l) + q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_z(r, l)/y_cc(k)*q_prim_vf(mom_idx%beg)%sf(j, k, & + & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%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(mom_idx%beg)%sf(j, k, r + l) & - - fd_coeff_x(r, j)* & - q_prim_vf(mom_idx%end)%sf(r + j, k, l) + q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg)%sf(j, k, & + & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%end)%sf(r + j, k, l) end if end do - end do end do end do @@ -449,174 +346,119 @@ contains do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - 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(mom_idx%beg + 1)%sf(r + j, k, l) & - - fd_coeff_y(r, k)* & - q_prim_vf(mom_idx%beg)%sf(j, r + k, l) + q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_x(r, j)*q_prim_vf(mom_idx%beg + 1)%sf(r + j, k, & + & l) - fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg)%sf(j, r + k, l) end do - end do end do end do end if - end subroutine s_derive_vorticity_component - - !> This subroutine gets as inputs the primitive variables. From those - !! inputs, it proceeds to calculate the value of the Q_M - !! function, which are subsequently stored in the derived flow - !! quantity storage variable, q_sf. - !! @param q_prim_vf Primitive variables - !! @param q_sf Q_M + !> This subroutine gets as inputs the primitive variables. From those inputs, it proceeds to calculate the value of the Q_M + !! function, which are subsequently stored in the derived flow quantity storage variable, q_sf. + !! @param q_prim_vf Primitive variables + !! @param q_sf Q_M subroutine s_derive_qm(q_prim_vf, q_sf) - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_prim_vf - - real(wp), & - dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & - intent(inout) :: q_sf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), & - dimension(1:3, 1:3) :: q_jacobian_sf, S, S2, O, O2 + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + & intent(inout) :: q_sf - real(wp) :: trS, Q, IIS - integer :: j, k, l, r, jj, kk !< Generic loop iterators + real(wp), dimension(1:3, 1:3) :: q_jacobian_sf, S, S2, O, O2 + real(wp) :: trS, Q, IIS + integer :: j, k, l, r, jj, kk !< Generic loop iterators do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - ! Get velocity gradient tensor - q_jacobian_sf(:, :) = 0._wp + q_jacobian_sf(:,:) = 0._wp 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, j)* & - q_prim_vf(mom_idx%beg + jj - 1)%sf(r + j, k, l) + q_jacobian_sf(jj, 1) = q_jacobian_sf(jj, 1) + fd_coeff_x(r, & + & j)*q_prim_vf(mom_idx%beg + jj - 1)%sf(r + j, k, l) ! d()/dy - q_jacobian_sf(jj, 2) = & - q_jacobian_sf(jj, 2) + & - fd_coeff_y(r, k)* & - q_prim_vf(mom_idx%beg + jj - 1)%sf(j, r + k, l) + q_jacobian_sf(jj, 2) = q_jacobian_sf(jj, 2) + fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg + jj - 1)%sf(j, & + & r + k, l) ! d()/dz - q_jacobian_sf(jj, 3) = & - q_jacobian_sf(jj, 3) + & - fd_coeff_z(r, l)* & - q_prim_vf(mom_idx%beg + jj - 1)%sf(j, k, r + l) + q_jacobian_sf(jj, 3) = q_jacobian_sf(jj, 3) + fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + jj - 1)%sf(j, & + & k, r + l) end do end do ! Decompose J into asymmetric matrix, S, and a skew-symmetric matrix, O do jj = 1, 3 do kk = 1, 3 - S(jj, kk) = 0.5_wp* & - (q_jacobian_sf(jj, kk) + q_jacobian_sf(kk, jj)) - O(jj, kk) = 0.5_wp* & - (q_jacobian_sf(jj, kk) - q_jacobian_sf(kk, jj)) + S(jj, kk) = 0.5_wp*(q_jacobian_sf(jj, kk) + q_jacobian_sf(kk, jj)) + O(jj, kk) = 0.5_wp*(q_jacobian_sf(jj, kk) - q_jacobian_sf(kk, jj)) end do end do ! Compute S2 = S*S' do jj = 1, 3 do kk = 1, 3 - O2(jj, kk) = O(jj, 1)*O(kk, 1) + & - O(jj, 2)*O(kk, 2) + & - O(jj, 3)*O(kk, 3) - S2(jj, kk) = S(jj, 1)*S(kk, 1) + & - S(jj, 2)*S(kk, 2) + & - S(jj, 3)*S(kk, 3) + O2(jj, kk) = O(jj, 1)*O(kk, 1) + O(jj, 2)*O(kk, 2) + O(jj, 3)*O(kk, 3) + S2(jj, kk) = S(jj, 1)*S(kk, 1) + S(jj, 2)*S(kk, 2) + S(jj, 3)*S(kk, 3) end do end do ! Compute Q - Q = 0.5_wp*((O2(1, 1) + O2(2, 2) + O2(3, 3)) - & - (S2(1, 1) + S2(2, 2) + S2(3, 3))) + Q = 0.5_wp*((O2(1, 1) + O2(2, 2) + O2(3, 3)) - (S2(1, 1) + S2(2, 2) + S2(3, 3))) trS = S(1, 1) + S(2, 2) + S(3, 3) - IIS = 0.5_wp*((S(1, 1) + S(2, 2) + S(3, 3))**2 - & - (S2(1, 1) + S2(2, 2) + S2(3, 3))) + IIS = 0.5_wp*((S(1, 1) + S(2, 2) + S(3, 3))**2 - (S2(1, 1) + S2(2, 2) + S2(3, 3))) q_sf(j, k, l) = Q + IIS - end do end do end do - end subroutine s_derive_qm - - !> This subroutine gets as inputs the primitive variables. From those - !! inputs, it proceeds to calculate the Liutex vector and its - !! magnitude based on Xu et al. (2019). - !! @param q_prim_vf Primitive variables + !> This subroutine gets as inputs the primitive variables. From those inputs, it proceeds to calculate the Liutex vector and its + !! magnitude based on Xu et al. (2019). + !! @param q_prim_vf Primitive variables impure subroutine s_derive_liutex(q_prim_vf, liutex_mag, liutex_axis) - integer, parameter :: nm = 3 - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_prim_vf - - real(wp), & - dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & - intent(out) :: liutex_mag !< Liutex magnitude - - real(wp), & - dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end, nm), & - intent(out) :: liutex_axis !< Liutex rigid rotation axis - - character, parameter :: ivl = 'N' !< compute left eigenvectors - character, parameter :: ivr = 'V' !< compute right eigenvectors - real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor - real(wp), dimension(nm) :: lr, li !< real and imaginary parts of eigenvalues - real(wp), dimension(nm, nm) :: vl, vr !< left and right eigenvectors - integer, parameter :: lwork = 4*nm !< size of work array (4*nm recommended) - real(wp), dimension(lwork) :: work !< work array - integer :: info + integer, parameter :: nm = 3 + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), dimension(nm) :: eigvec !< real eigenvector - real(wp) :: eigvec_mag !< magnitude of real eigenvector - real(wp) :: omega_proj !< projection of vorticity on real eigenvector - real(wp) :: lci !< imaginary part of complex eigenvalue - real(wp) :: alpha + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + & intent(out) :: liutex_mag !< Liutex magnitude - integer :: j, k, l, r, i !< Generic loop iterators - integer :: idx + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, nm), & + & intent(out) :: liutex_axis !< Liutex rigid rotation axis + + character, parameter :: ivl = 'N' !< compute left eigenvectors + character, parameter :: ivr = 'V' !< compute right eigenvectors + real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor + real(wp), dimension(nm) :: lr, li !< real and imaginary parts of eigenvalues + real(wp), dimension(nm, nm) :: vl, vr !< left and right eigenvectors + integer, parameter :: lwork = 4*nm !< size of work array (4*nm recommended) + real(wp), dimension(lwork) :: work !< work array + integer :: info + real(wp), dimension(nm) :: eigvec !< real eigenvector + real(wp) :: eigvec_mag !< magnitude of real eigenvector + real(wp) :: omega_proj !< projection of vorticity on real eigenvector + real(wp) :: lci !< imaginary part of complex eigenvalue + real(wp) :: alpha + integer :: j, k, l, r, i !< Generic loop iterators + integer :: idx do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - ! Get velocity gradient tensor (VGT) - vgt(:, :) = 0._wp + vgt(:,:) = 0._wp 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(mom_idx%beg + i - 1)%sf(r + j, k, l) + vgt(i, 1) = vgt(i, 1) + fd_coeff_x(r, j)*q_prim_vf(mom_idx%beg + i - 1)%sf(r + j, k, l) ! d()/dy - vgt(i, 2) = & - vgt(i, 2) + & - fd_coeff_y(r, k)* & - q_prim_vf(mom_idx%beg + i - 1)%sf(j, r + k, l) + vgt(i, 2) = vgt(i, 2) + fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg + i - 1)%sf(j, r + k, l) ! d()/dz - vgt(i, 3) = & - vgt(i, 3) + & - fd_coeff_z(r, l)* & - q_prim_vf(mom_idx%beg + i - 1)%sf(j, k, r + l) + vgt(i, 3) = vgt(i, 3) + fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + i - 1)%sf(j, k, r + l) end do end do @@ -637,9 +479,7 @@ contains eigvec = vr(:, idx) ! Normalize real eigenvector if it is effectively non-zero - eigvec_mag = sqrt(eigvec(1)**2._wp & - + eigvec(2)**2._wp & - + eigvec(3)**2._wp) + eigvec_mag = sqrt(eigvec(1)**2._wp + eigvec(2)**2._wp + eigvec(3)**2._wp) if (eigvec_mag > sgm_eps) then eigvec = eigvec/eigvec_mag else @@ -647,9 +487,8 @@ contains end if ! Compute vorticity projected on the eigenvector - omega_proj = (vgt(3, 2) - vgt(2, 3))*eigvec(1) & - + (vgt(1, 3) - vgt(3, 1))*eigvec(2) & - + (vgt(2, 1) - vgt(1, 2))*eigvec(3) + omega_proj = (vgt(3, 2) - vgt(2, 3))*eigvec(1) + (vgt(1, 3) - vgt(3, 1))*eigvec(2) + (vgt(2, 1) - vgt(1, & + & 2))*eigvec(3) ! As eigenvector can have +/- signs, we can choose the sign ! so that omega_proj is positive @@ -673,31 +512,19 @@ contains liutex_axis(j, k, l, 1) = eigvec(1) liutex_axis(j, k, l, 2) = eigvec(2) liutex_axis(j, k, l, 3) = eigvec(3) - end do end do end do - end subroutine s_derive_liutex - - !> This subroutine gets as inputs the conservative variables - !! and density. From those inputs, it proceeds to calculate - !! the values of the numerical Schlieren function, which are - !! subsequently stored in the derived flow quantity storage - !! variable, q_sf. - !! @param q_cons_vf Conservative variables - !! @param q_sf Numerical Schlieren function + !> This subroutine gets as inputs the conservative variables and density. From those inputs, it proceeds to calculate the values + !! of the numerical Schlieren function, which are subsequently stored in the derived flow quantity storage variable, q_sf. + !! @param q_cons_vf Conservative variables + !! @param q_sf Numerical Schlieren function impure subroutine s_derive_numerical_schlieren_function(q_cons_vf, q_sf) + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_cons_vf - - real(wp), & - dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end), & - intent(inout) :: q_sf + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + & intent(inout) :: q_sf real(wp) :: drho_dx, drho_dy, drho_dz !< !! Spatial derivatives of the density in the x-, y- and z-directions @@ -716,7 +543,6 @@ contains do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - drho_dx = 0._wp drho_dy = 0._wp @@ -726,7 +552,6 @@ contains end do gm_rho_sf(j, k, l) = drho_dx*drho_dx + drho_dy*drho_dy - end do end do end do @@ -736,22 +561,17 @@ contains do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - drho_dz = 0._wp 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_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_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 - + gm_rho_sf(j, k, l) = gm_rho_sf(j, k, l) + drho_dz*drho_dz end do end do end do @@ -783,21 +603,17 @@ contains ! identity of the fluid in which the function is evaluated. For more ! information, refer to Marquina and Mulet (2003). - if (model_eqns == 1) then ! Gamma/pi_inf model + if (model_eqns == 1) then ! Gamma/pi_inf model q_sf = -gm_rho_sf/gm_rho_max(1) - - else ! Volume fraction model + else ! Volume fraction model do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end - q_sf(j, k, l) = 0._wp do i = 1, adv_idx%end - E_idx - q_sf(j, k, l) = & - q_sf(j, k, l) - schlieren_alpha(i)* & - q_cons_vf(i + E_idx)%sf(j, k, l)* & - gm_rho_sf(j, k, l)/gm_rho_max(1) + q_sf(j, k, l) = q_sf(j, k, l) - schlieren_alpha(i)*q_cons_vf(i + E_idx)%sf(j, k, l)*gm_rho_sf(j, k, & + & l)/gm_rho_max(1) end do end do end do @@ -808,12 +624,9 @@ contains ! Schlieren function has been evaluated and stored. Then, to finish ! the computation, the exponential of the inside quantity is taken. q_sf = exp(q_sf) - end subroutine s_derive_numerical_schlieren_function - - !> Deallocation procedures for the module + !> Deallocation procedures for the module impure subroutine s_finalize_derived_variables_module - ! Deallocating the variable containing the gradient magnitude of the ! density field provided that the numerical Schlieren function was ! was outputted during the post-process @@ -824,7 +637,5 @@ contains 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) - end subroutine s_finalize_derived_variables_module - end module m_derived_variables diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index c92f0725be..5595f0f0db 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -6,7 +6,6 @@ !> @brief Global parameters for the post-process: domain geometry, equation of state, and output database settings module m_global_parameters - #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -21,7 +20,7 @@ module m_global_parameters !> @name Logistics !> @{ - integer :: num_procs !< Number of processors + integer :: num_procs !< Number of processors character(LEN=path_len) :: case_dir !< Case folder location !> @} @@ -38,8 +37,7 @@ module m_global_parameters !> @name Max and min number of cells in a direction of each combination of x-,y-, and z- type(cell_num_bounds) :: cells_bounds - - integer(kind=8) :: nGlobal ! Total number of cells in global domain + integer(kind=8) :: nGlobal ! Total number of cells in global domain !> @name Cylindrical coordinates (either axisymmetric or full 3D) !> @{ @@ -82,12 +80,12 @@ module m_global_parameters !> @name IO options for adaptive time-stepping !> @{ - logical :: cfl_adap_dt, cfl_const_dt, cfl_dt + logical :: cfl_adap_dt, cfl_const_dt, cfl_dt real(wp) :: t_save real(wp) :: t_stop real(wp) :: cfl_target - integer :: n_save - integer :: n_start + integer :: n_save + integer :: n_start !> @} ! NOTE: The variables m_root, x_root_cb and x_root_cc contain the grid data @@ -96,28 +94,28 @@ module m_global_parameters !> @name Simulation Algorithm Parameters !> @{ - integer :: model_eqns !< Multicomponent flow model - integer :: num_fluids !< Number of different fluids present in the flow - logical :: relax !< phase change - integer :: relax_model !< Phase change relaxation model - logical :: mpp_lim !< Maximum volume fraction limiter - integer :: sys_size !< Number of unknowns in the system of equations - integer :: recon_type !< Which type of reconstruction to use - integer :: weno_order !< Order of accuracy for the WENO reconstruction - integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction - logical :: mixture_err !< Mixture error limiter - logical :: alt_soundspeed !< Alternate sound speed - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity for RMHD - logical :: hypoelasticity !< Turn hypoelasticity on - logical :: hyperelasticity !< Turn hyperelasticity on - logical :: elasticity !< elasticity modeling, true for hyper or hypo - integer :: b_size !< Number of components in the b tensor - integer :: tensor_size !< Number of components in the nonsymmetric tensor - logical :: cont_damage !< Continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD - logical :: igr !< enable IGR - integer :: igr_order !< IGR reconstruction order + integer :: model_eqns !< Multicomponent flow model + integer :: num_fluids !< Number of different fluids present in the flow + logical :: relax !< phase change + integer :: relax_model !< Phase change relaxation model + logical :: mpp_lim !< Maximum volume fraction limiter + integer :: sys_size !< Number of unknowns in the system of equations + integer :: recon_type !< Which type of reconstruction to use + integer :: weno_order !< Order of accuracy for the WENO reconstruction + integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction + logical :: mixture_err !< Mixture error limiter + logical :: alt_soundspeed !< Alternate sound speed + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity for RMHD + logical :: hypoelasticity !< Turn hypoelasticity on + logical :: hyperelasticity !< Turn hyperelasticity on + logical :: elasticity !< elasticity modeling, true for hyper or hypo + integer :: b_size !< Number of components in the b tensor + integer :: tensor_size !< Number of components in the nonsymmetric tensor + logical :: cont_damage !< Continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD + logical :: igr !< enable IGR + integer :: igr_order !< IGR reconstruction order logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling !> @} @@ -127,22 +125,22 @@ module m_global_parameters !> @{ type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of energy equation - integer :: n_idx !< Index of number density - integer :: beta_idx !< Index of lagrange bubbles beta + integer :: E_idx !< Index of energy equation + integer :: n_idx !< Index of number density + integer :: beta_idx !< Index of lagrange bubbles beta type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: alf_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: alf_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. type(int_bounds_info) :: stress_idx !< Indices of elastic stresses type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: c_idx !< Index of color function + integer :: c_idx !< Index of color function type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD !> @} ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). @@ -153,15 +151,14 @@ module m_global_parameters ! the buffer region. idwbuff and idwint are the same otherwise. ! Stands for "InDices With BUFFer". type(int_bounds_info) :: idwbuff(1:3) - - integer :: num_bc_patches - logical :: bc_io + integer :: num_bc_patches + logical :: bc_io !> @name Boundary conditions in the x-, y- and z-coordinate directions !> @{ type(int_bounds_info) :: bc_x, bc_y, bc_z !> @} - integer :: shear_num !! Number of shear stress components + integer :: shear_num !! Number of shear stress components integer, dimension(3) :: shear_indices !< !! Indices of the stress components that represent shear stress integer :: shear_BC_flip_num !< @@ -170,10 +167,9 @@ module m_global_parameters !! Indices of shear stress components to reflect for boundary conditions. !! Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, [indices]) - logical :: parallel_io !< Format of the data files - logical :: sim_data - logical :: file_per_process !< output format - + logical :: parallel_io !< Format of the data files + logical :: sim_data + logical :: file_per_process !< output format integer, allocatable, dimension(:) :: proc_coords !< !! Processor coordinates in MPI_CART_COMM @@ -184,18 +180,17 @@ module m_global_parameters #ifdef MFC_MPI - type(mpi_io_var), public :: MPI_IO_DATA - type(mpi_io_ib_var), public :: MPI_IO_IB_DATA - type(mpi_io_levelset_var), public :: MPI_IO_levelset_DATA - type(mpi_io_levelset_norm_var), public :: MPI_IO_levelsetnorm_DATA - real(wp), allocatable, dimension(:, :), public :: MPI_IO_DATA_lg_bubbles - + type(mpi_io_var), public :: MPI_IO_DATA + type(mpi_io_ib_var), public :: MPI_IO_IB_DATA + type(mpi_io_levelset_var), public :: MPI_IO_levelset_DATA + type(mpi_io_levelset_norm_var), public :: MPI_IO_levelsetnorm_DATA + real(wp), allocatable, dimension(:,:), public :: MPI_IO_DATA_lg_bubbles #endif !> @name MPI info for parallel IO with Lustre file systems !> @{ character(LEN=name_len) :: mpiiofs - integer :: mpi_info_int + integer :: mpi_info_int !> @} type(physical_parameters), dimension(num_fluids_max) :: fluid_pp !< @@ -205,83 +200,75 @@ module m_global_parameters ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp - - real(wp), allocatable, dimension(:) :: adv !< Advection variables + real(wp), allocatable, dimension(:) :: adv !< Advection variables ! Formatted Database File(s) Structure Parameters - integer :: format !< Format of the database file(s) - - integer :: precision !< Floating point precision of the database file(s) - logical :: down_sample !< down sampling of the database file(s) - - logical :: output_partial_domain !< Specify portion of domain to output for post-processing - - type(bounds_info) :: x_output, y_output, z_output !< Portion of domain to output for post-processing + integer :: format !< Format of the database file(s) + integer :: precision !< Floating point precision of the database file(s) + logical :: down_sample !< down sampling of the database file(s) + logical :: output_partial_domain !< Specify portion of domain to output for post-processing + type(bounds_info) :: x_output, y_output, z_output !< Portion of domain to output for post-processing type(int_bounds_info) :: x_output_idx, y_output_idx, z_output_idx !< Indices of domain to output for post-processing - !> @name Size of the ghost zone layer in the x-, y- and z-coordinate directions. - !! The definition of the ghost zone layers is only necessary when using the - !! Silo database file format in multidimensions. These zones provide VisIt - !! with the subdomain connectivity information that it requires in order to - !! produce smooth plots. + !> @name Size of the ghost zone layer in the x-, y- and z-coordinate directions. The definition of the ghost zone layers is only + !! necessary when using the Silo database file format in multidimensions. These zones provide VisIt with the subdomain + !! connectivity information that it requires in order to produce smooth plots. !> @{ type(int_bounds_info) :: offset_x, offset_y, offset_z !> @} - !> @name The list of all possible flow variables that may be written to a database - !! file. It includes partial densities, density, momentum, velocity, energy, - !! pressure, volume fraction(s), specific heat ratio function, specific heat - !! ratio, liquid stiffness function, liquid stiffness, primitive variables, - !! conservative variables, speed of sound, the vorticity, - !! and the numerical Schlieren function. + !> @name The list of all possible flow variables that may be written to a database file. It includes partial densities, density, + !! momentum, velocity, energy, pressure, volume fraction(s), specific heat ratio function, specific heat ratio, liquid stiffness + !! function, liquid stiffness, primitive variables, conservative variables, speed of sound, the vorticity, and the numerical + !! Schlieren function. !> @{ logical, dimension(num_fluids_max) :: alpha_rho_wrt - logical :: rho_wrt - logical, dimension(3) :: mom_wrt - logical, dimension(3) :: vel_wrt - integer :: flux_lim - logical, dimension(3) :: flux_wrt - logical :: E_wrt + logical :: rho_wrt + logical, dimension(3) :: mom_wrt + logical, dimension(3) :: vel_wrt + integer :: flux_lim + logical, dimension(3) :: flux_wrt + logical :: E_wrt logical, dimension(num_fluids_max) :: alpha_rho_e_wrt - logical :: fft_wrt - logical :: dummy !< AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional is false - logical :: pres_wrt + logical :: fft_wrt + logical :: dummy !< AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional is false + logical :: pres_wrt logical, dimension(num_fluids_max) :: alpha_wrt - logical :: gamma_wrt - logical :: heat_ratio_wrt - logical :: pi_inf_wrt - logical :: pres_inf_wrt - logical :: prim_vars_wrt - logical :: cons_vars_wrt - logical :: c_wrt - logical, dimension(3) :: omega_wrt - logical :: qm_wrt - logical :: liutex_wrt - logical :: schlieren_wrt - logical :: cf_wrt - logical :: ib - logical :: ib_state_wrt - logical :: chem_wrt_Y(1:num_species) - logical :: chem_wrt_T - logical :: lag_header - logical :: lag_txt_wrt - logical :: lag_db_wrt - logical :: lag_id_wrt - logical :: lag_pos_wrt - logical :: lag_pos_prev_wrt - logical :: lag_vel_wrt - logical :: lag_rad_wrt - logical :: lag_rvel_wrt - logical :: lag_r0_wrt - logical :: lag_rmax_wrt - logical :: lag_rmin_wrt - logical :: lag_dphidt_wrt - logical :: lag_pres_wrt - logical :: lag_mv_wrt - logical :: lag_mg_wrt - logical :: lag_betaT_wrt - logical :: lag_betaC_wrt + logical :: gamma_wrt + logical :: heat_ratio_wrt + logical :: pi_inf_wrt + logical :: pres_inf_wrt + logical :: prim_vars_wrt + logical :: cons_vars_wrt + logical :: c_wrt + logical, dimension(3) :: omega_wrt + logical :: qm_wrt + logical :: liutex_wrt + logical :: schlieren_wrt + logical :: cf_wrt + logical :: ib + logical :: ib_state_wrt + logical :: chem_wrt_Y(1:num_species) + logical :: chem_wrt_T + logical :: lag_header + logical :: lag_txt_wrt + logical :: lag_db_wrt + logical :: lag_id_wrt + logical :: lag_pos_wrt + logical :: lag_pos_prev_wrt + logical :: lag_vel_wrt + logical :: lag_rad_wrt + logical :: lag_rvel_wrt + logical :: lag_r0_wrt + logical :: lag_rmax_wrt + logical :: lag_rmin_wrt + logical :: lag_dphidt_wrt + logical :: lag_pres_wrt + logical :: lag_mv_wrt + logical :: lag_mg_wrt + logical :: lag_betaT_wrt + logical :: lag_betaC_wrt !> @} real(wp), dimension(num_fluids_max) :: schlieren_alpha !< @@ -294,7 +281,6 @@ module m_global_parameters !! The order of the finite-difference (fd) approximations of the first-order !! derivatives that need to be evaluated when vorticity and/or the numerical !! Schlieren function are to be outputted to the formatted database file(s). - integer :: fd_number !< !! The finite-difference number is given by MAX(1, fd_order/2). Essentially, !! it is a measure of the half-size of the finite-difference stencil for the @@ -308,32 +294,31 @@ module m_global_parameters type(chemistry_parameters) :: chem_params !> @name Bubble modeling variables and parameters !> @{ - integer :: nb - real(wp) :: Eu, Ca, Web, Re_inv + integer :: nb + real(wp) :: Eu, Ca, Web, Re_inv real(wp), dimension(:), allocatable :: weight, R0 - logical :: bubbles_euler - logical :: qbmm - logical :: polytropic - logical :: polydisperse - logical :: adv_n - integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer - real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl - real(wp) :: gam_m + logical :: bubbles_euler + logical :: qbmm + logical :: polytropic + logical :: polydisperse + logical :: adv_n + integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer + real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl + real(wp) :: gam_m real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g real(wp), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN - real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, & - gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g - real(wp) :: G - real(wp) :: poly_sigma - real(wp) :: sigR - integer :: nmom + real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g + real(wp) :: G + real(wp) :: poly_sigma + real(wp) :: sigR + integer :: nmom !> @} !> @name surface tension coefficient !> @{ real(wp) :: sigma - logical :: surface_tension + logical :: surface_tension !> @} !> @name Index variables used for m_variables_conversion @@ -354,16 +339,12 @@ module m_global_parameters !> @} real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) - real(wp) :: wall_time, wall_time_avg !< Wall time measurements - contains - !> Assigns default values to user inputs prior to reading - !! them in. This allows for an easier consistency check of - !! these parameters once they are read from the input file. + !> Assigns default values to user inputs prior to reading them in. This allows for an easier consistency check of these + !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs - integer :: i !< Generic loop iterator ! Logistics @@ -452,8 +433,8 @@ contains bub_pp%gam_g = dflt_real; gam_g = dflt_real bub_pp%M_v = dflt_real; M_v = dflt_real bub_pp%M_g = dflt_real; M_g = dflt_real - bub_pp%k_v = dflt_real; - bub_pp%k_g = dflt_real; + bub_pp%k_v = dflt_real; + bub_pp%k_g = dflt_real; bub_pp%cp_v = dflt_real; cp_v = dflt_real bub_pp%cp_g = dflt_real; cp_g = dflt_real bub_pp%R_v = dflt_real; R_v = dflt_real @@ -553,13 +534,9 @@ contains ! MHD Bx0 = dflt_real - end subroutine s_assign_default_values_to_user_inputs - - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_global_parameters_module - integer :: i, j, fac ! Setting m_root equal to m in the case of a 1D serial simulation @@ -567,7 +544,6 @@ contains ! Gamma/Pi_inf Model if (model_eqns == 1) then - ! Setting number of fluids num_fluids = 1 @@ -587,7 +563,6 @@ contains ! Volume Fraction Model (5-equation model) else if (model_eqns == 2) then - ! Annotating structure of the state and flux vectors belonging ! to the system of equations defined by the selected number of ! spatial dimensions and the volume fraction model @@ -626,7 +601,6 @@ contains end if if (bubbles_euler) then - bub_idx%beg = sys_size + 1 if (qbmm) then bub_idx%end = adv_idx%end + nb*nmom @@ -692,7 +666,6 @@ contains ! Volume Fraction Model (6-equation model) else if (model_eqns == 3) then - ! Annotating structure of the state and flux vectors belonging ! to the system of equations defined by the selected number of ! spatial dimensions and the volume fraction model @@ -707,17 +680,16 @@ contains internalEnergies_idx%end = adv_idx%end + num_fluids sys_size = internalEnergies_idx%end alf_idx = 1 ! dummy, cannot actually have a void fraction - else if (model_eqns == 4) then cont_idx%beg = 1 ! one continuity equation - cont_idx%end = 1 !num_fluids + cont_idx%end = 1 ! num_fluids mom_idx%beg = cont_idx%end + 1 ! one momentum equation in each mom_idx%end = cont_idx%end + num_vels E_idx = mom_idx%end + 1 ! one energy equation adv_idx%beg = E_idx + 1 - adv_idx%end = adv_idx%beg !one volume advection equation + adv_idx%end = adv_idx%beg ! one volume advection equation alf_idx = adv_idx%end - sys_size = alf_idx !adv_idx%end + sys_size = alf_idx ! adv_idx%end if (bubbles_euler) then bub_idx%beg = sys_size + 1 @@ -762,7 +734,6 @@ contains end if if (model_eqns == 2 .or. model_eqns == 3) then - if (hypoelasticity .or. hyperelasticity) then elasticity = .true. stress_idx%beg = sys_size + 1 @@ -821,7 +792,6 @@ contains else psi_idx = dflt_int end if - end if if (chemistry) then @@ -892,26 +862,20 @@ contains ! whether the raw simulation data is 2D or 3D. In the 2D case, size ! of the z-coordinate direction ghost zone layer must be zeroed out. if (num_procs == 1 .or. format /= 1) then - offset_x%beg = 0 offset_x%end = 0 offset_y%beg = 0 offset_y%end = 0 offset_z%beg = 0 offset_z%end = 0 - - elseif (n == 0) then - + else if (n == 0) then offset_y%beg = 0 offset_y%end = 0 offset_z%beg = 0 offset_z%end = 0 - - elseif (p == 0) then - + else if (p == 0) then offset_z%beg = 0 offset_z%end = 0 - end if ! Determining the finite-difference number and the buffer size. Note @@ -920,8 +884,7 @@ contains ! zone layers and possibly the order of the finite difference scheme ! used for the computation of vorticity and/or numerical Schlieren ! function. - buff_size = max(offset_x%beg, offset_x%end, offset_y%beg, & - offset_y%end, offset_z%beg, offset_z%end) + buff_size = max(offset_x%beg, offset_x%end, offset_y%beg, offset_y%end, offset_z%beg, offset_z%end) if (any(omega_wrt) .or. schlieren_wrt .or. qm_wrt .or. liutex_wrt) then fd_number = max(1, fd_order/2) @@ -950,7 +913,6 @@ contains ! Allocating grid variables in the y- and z-coordinate directions if (n > 0) then - allocate (y_cb(-1 - offset_y%beg:n + offset_y%end)) allocate (y_cc(-buff_size:n + buff_size)) allocate (dy(-buff_size:n + buff_size)) @@ -971,24 +933,20 @@ contains if (precision == 1) then allocate (x_root_cc_s(0:m_root)) end if - end if allocate (adv(num_fluids)) if (cyl_coord .neqv. .true.) then ! Cartesian grid grid_geometry = 1 - elseif (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid + else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid grid_geometry = 2 else ! Fully 3D cylindrical grid grid_geometry = 3 end if - end subroutine s_initialize_global_parameters_module - !> Subroutine to initialize parallel infrastructure impure subroutine s_initialize_parallel_io - #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors #endif @@ -1019,14 +977,10 @@ contains ! mpi_info_int = MPI_INFO_NULL allocate (start_idx(1:num_dims)) - #endif - end subroutine s_initialize_parallel_io - !> Deallocation procedures for the module impure subroutine s_finalize_global_parameters_module - integer :: i ! Deallocating the grid variables for the x-coordinate direction @@ -1062,7 +1016,5 @@ contains if (ib) MPI_IO_IB_DATA%var%sf => null() #endif - end subroutine s_finalize_global_parameters_module - end module m_global_parameters diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index d0a1311f4e..fc104b799f 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -4,7 +4,6 @@ !> @brief MPI gather and scatter operations for distributing post-process grid and flow-variable data module m_mpi_proxy - #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -19,20 +18,16 @@ module m_mpi_proxy implicit none - !> @name Receive counts and displacement vector variables, respectively, used in - !! enabling MPI to gather varying amounts of data from all processes to the - !! root process + !> @name Receive counts and displacement vector variables, respectively, used in enabling MPI to gather varying amounts of data + !! from all processes to the root process !> @{ integer, allocatable, dimension(:) :: recvcounts integer, allocatable, dimension(:) :: displs !> @} - contains - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_mpi_proxy_module - #ifdef MFC_MPI integer :: i !< Generic loop iterator @@ -43,14 +38,12 @@ contains ! Note that these are only needed for either multidimensional runs ! that utilize the Silo database file format or for 1D simulations. if ((format == 1 .and. n > 0) .or. n == 0) then - allocate (recvcounts(0:num_procs - 1)) allocate (displs(0:num_procs - 1)) if (n == 0) then - call MPI_GATHER(m + 1, 1, MPI_INTEGER, recvcounts(0), 1, & - MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - elseif (proc_rank == 0) then + call MPI_GATHER(m + 1, 1, MPI_INTEGER, recvcounts(0), 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + else if (proc_rank == 0) then recvcounts = 1 end if @@ -61,20 +54,12 @@ contains displs(i) = displs(i - 1) + recvcounts(i - 1) end do end if - end if - #endif - end subroutine s_initialize_mpi_proxy_module - - !> Since only processor with rank 0 is in charge of reading - !! and checking the consistency of the user provided inputs, - !! these are not available to the remaining processors. This - !! subroutine is then in charge of broadcasting the required - !! information. + !> Since only processor with rank 0 is in charge of reading and checking the consistency of the user provided inputs, these are + !! not available to the remaining processors. This subroutine is then in charge of broadcasting the required information. impure subroutine s_mpi_bcast_user_inputs - #ifdef MFC_MPI integer :: i !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors @@ -149,124 +134,82 @@ contains #:endfor call MPI_BCAST(schlieren_alpha(1), num_fluids_max, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif - end subroutine s_mpi_bcast_user_inputs - - !> This subroutine gathers the Silo database metadata for - !! the spatial extents in order to boost the performance of - !! the multidimensional visualization. - !! @param spatial_extents Spatial extents for each processor's sub-domain. First dimension - !! corresponds to the minimum and maximum values, respectively, while - !! the second dimension corresponds to the processor rank. + !> This subroutine gathers the Silo database metadata for the spatial extents in order to boost the performance of the + !! multidimensional visualization. + ! ! @param spatial_extents Spatial extents for each processor's sub-domain. First dimension corresponds to the minimum and + ! maximum values, respectively, while the second dimension corresponds to the processor rank. impure subroutine s_mpi_gather_spatial_extents(spatial_extents) - - real(wp), dimension(1:, 0:), intent(INOUT) :: spatial_extents + real(wp), dimension(1:, 0:), intent(inout) :: spatial_extents #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors real(wp) :: ext_temp(0:num_procs - 1) ! Simulation is 3D if (p > 0) then if (grid_geometry == 3) then ! Minimum spatial extent in the r-direction - call MPI_GATHERV(minval(y_cb), 1, mpi_p, & - spatial_extents(1, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(minval(y_cb), 1, mpi_p, spatial_extents(1, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Minimum spatial extent in the theta-direction - call MPI_GATHERV(minval(z_cb), 1, mpi_p, & - spatial_extents(2, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(minval(z_cb), 1, mpi_p, spatial_extents(2, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Minimum spatial extent in the z-direction - call MPI_GATHERV(minval(x_cb), 1, mpi_p, & - spatial_extents(3, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(minval(x_cb), 1, mpi_p, spatial_extents(3, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Maximum spatial extent in the r-direction - call MPI_GATHERV(maxval(y_cb), 1, mpi_p, & - spatial_extents(4, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(maxval(y_cb), 1, mpi_p, spatial_extents(4, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Maximum spatial extent in the theta-direction - call MPI_GATHERV(maxval(z_cb), 1, mpi_p, & - spatial_extents(5, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(maxval(z_cb), 1, mpi_p, spatial_extents(5, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Maximum spatial extent in the z-direction - call MPI_GATHERV(maxval(x_cb), 1, mpi_p, & - spatial_extents(6, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(maxval(x_cb), 1, mpi_p, spatial_extents(6, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) else ! Minimum spatial extent in the x-direction - call MPI_GATHERV(minval(x_cb), 1, mpi_p, & - spatial_extents(1, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(minval(x_cb), 1, mpi_p, spatial_extents(1, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Minimum spatial extent in the y-direction - call MPI_GATHERV(minval(y_cb), 1, mpi_p, & - spatial_extents(2, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(minval(y_cb), 1, mpi_p, spatial_extents(2, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Minimum spatial extent in the z-direction - call MPI_GATHERV(minval(z_cb), 1, mpi_p, & - spatial_extents(3, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(minval(z_cb), 1, mpi_p, spatial_extents(3, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Maximum spatial extent in the x-direction - call MPI_GATHERV(maxval(x_cb), 1, mpi_p, & - spatial_extents(4, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(maxval(x_cb), 1, mpi_p, spatial_extents(4, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Maximum spatial extent in the y-direction - call MPI_GATHERV(maxval(y_cb), 1, mpi_p, & - spatial_extents(5, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(maxval(y_cb), 1, mpi_p, spatial_extents(5, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) ! Maximum spatial extent in the z-direction - call MPI_GATHERV(maxval(z_cb), 1, mpi_p, & - spatial_extents(6, 0), recvcounts, 6*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(maxval(z_cb), 1, mpi_p, spatial_extents(6, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & + & ierr) end if ! Simulation is 2D - elseif (n > 0) then - + else if (n > 0) then ! Minimum spatial extent in the x-direction - call MPI_GATHERV(minval(x_cb), 1, mpi_p, & - spatial_extents(1, 0), recvcounts, 4*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(minval(x_cb), 1, mpi_p, spatial_extents(1, 0), recvcounts, 4*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) ! Minimum spatial extent in the y-direction - call MPI_GATHERV(minval(y_cb), 1, mpi_p, & - spatial_extents(2, 0), recvcounts, 4*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(minval(y_cb), 1, mpi_p, spatial_extents(2, 0), recvcounts, 4*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) ! Maximum spatial extent in the x-direction - call MPI_GATHERV(maxval(x_cb), 1, mpi_p, & - spatial_extents(3, 0), recvcounts, 4*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(maxval(x_cb), 1, mpi_p, spatial_extents(3, 0), recvcounts, 4*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) ! Maximum spatial extent in the y-direction - call MPI_GATHERV(maxval(y_cb), 1, mpi_p, & - spatial_extents(4, 0), recvcounts, 4*displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(maxval(y_cb), 1, mpi_p, spatial_extents(4, 0), recvcounts, 4*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) ! Simulation is 1D else @@ -274,114 +217,74 @@ contains ! (m+1 per rank), not for scalar gathers. Use MPI_GATHER instead. ! Minimum spatial extent in the x-direction - call MPI_GATHER(minval(x_cb), 1, mpi_p, & - ext_temp, 1, mpi_p, 0, & - MPI_COMM_WORLD, ierr) - if (proc_rank == 0) spatial_extents(1, :) = ext_temp + call MPI_GATHER(minval(x_cb), 1, mpi_p, ext_temp, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + if (proc_rank == 0) spatial_extents(1,:) = ext_temp ! Maximum spatial extent in the x-direction - call MPI_GATHER(maxval(x_cb), 1, mpi_p, & - ext_temp, 1, mpi_p, 0, & - MPI_COMM_WORLD, ierr) - if (proc_rank == 0) spatial_extents(2, :) = ext_temp + call MPI_GATHER(maxval(x_cb), 1, mpi_p, ext_temp, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + if (proc_rank == 0) spatial_extents(2,:) = ext_temp end if - #endif - end subroutine s_mpi_gather_spatial_extents - - !> This subroutine collects the sub-domain cell-boundary or - !! cell-center locations data from all of the processors and - !! puts back together the grid of the entire computational - !! domain on the rank 0 processor. This is only done for 1D - !! simulations. + !> This subroutine collects the sub-domain cell-boundary or cell-center locations data from all of the processors and puts back + !! together the grid of the entire computational domain on the rank 0 processor. This is only done for 1D simulations. impure subroutine s_mpi_defragment_1d_grid_variable - #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Silo-HDF5 database format if (format == 1) then - - call MPI_GATHERV(x_cc(0), m + 1, mpi_p, & - x_root_cc(0), recvcounts, displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(x_cc(0), m + 1, mpi_p, x_root_cc(0), recvcounts, displs, mpi_p, 0, MPI_COMM_WORLD, ierr) ! Binary database format else - call MPI_GATHERV(x_cb(0), m + 1, mpi_p, & - x_root_cb(0), recvcounts, displs, & - mpi_p, 0, MPI_COMM_WORLD, & - ierr) + call MPI_GATHERV(x_cb(0), m + 1, mpi_p, x_root_cb(0), recvcounts, displs, mpi_p, 0, MPI_COMM_WORLD, ierr) if (proc_rank == 0) x_root_cb(-1) = x_cb(-1) - end if - #endif - end subroutine s_mpi_defragment_1d_grid_variable - - !> This subroutine gathers the Silo database metadata for - !! the flow variable's extents as to boost performance of - !! the multidimensional visualization. - !! @param q_sf Flow variable defined on a single computational sub-domain - !! @param data_extents The flow variable extents on each of the processor's sub-domain. - !! First dimension of array corresponds to the former's minimum and - !! maximum values, respectively, while second dimension corresponds - !! to each processor's rank. + !> This subroutine gathers the Silo database metadata for the flow variable's extents as to boost performance of the + !! multidimensional visualization. + !! @param q_sf Flow variable defined on a single computational sub-domain + ! ! @param data_extents The flow variable extents on each of the processor's sub-domain. First dimension of array corresponds to + ! the former's minimum and maximum values, respectively, while second dimension corresponds to each processor's rank. impure subroutine s_mpi_gather_data_extents(q_sf, data_extents) - - real(wp), dimension(:, :, :), intent(in) :: q_sf + real(wp), dimension(:,:,:), intent(in) :: q_sf real(wp), dimension(1:2, 0:num_procs - 1), intent(inout) :: data_extents #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors real(wp) :: ext_temp(0:num_procs - 1) if (n > 0) then ! Multi-D: recvcounts = 1, so strided MPI_GATHERV works correctly ! Minimum flow variable extent - call MPI_GATHERV(minval(q_sf), 1, mpi_p, & - data_extents(1, 0), recvcounts, 2*displs, & - mpi_p, 0, MPI_COMM_WORLD, ierr) + call MPI_GATHERV(minval(q_sf), 1, mpi_p, data_extents(1, 0), recvcounts, 2*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) ! Maximum flow variable extent - call MPI_GATHERV(maxval(q_sf), 1, mpi_p, & - data_extents(2, 0), recvcounts, 2*displs, & - mpi_p, 0, MPI_COMM_WORLD, ierr) + call MPI_GATHERV(maxval(q_sf), 1, mpi_p, data_extents(2, 0), recvcounts, 2*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) else ! 1D: recvcounts/displs are sized for grid defragmentation ! (m+1 per rank), not for scalar gathers. Use MPI_GATHER instead. ! Minimum flow variable extent - call MPI_GATHER(minval(q_sf), 1, mpi_p, & - ext_temp, 1, mpi_p, 0, & - MPI_COMM_WORLD, ierr) - if (proc_rank == 0) data_extents(1, :) = ext_temp + call MPI_GATHER(minval(q_sf), 1, mpi_p, ext_temp, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + if (proc_rank == 0) data_extents(1,:) = ext_temp ! Maximum flow variable extent - call MPI_GATHER(maxval(q_sf), 1, mpi_p, & - ext_temp, 1, mpi_p, 0, & - MPI_COMM_WORLD, ierr) - if (proc_rank == 0) data_extents(2, :) = ext_temp + call MPI_GATHER(maxval(q_sf), 1, mpi_p, ext_temp, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) + if (proc_rank == 0) data_extents(2,:) = ext_temp end if - #endif - end subroutine s_mpi_gather_data_extents - - !> This subroutine gathers the sub-domain flow variable data - !! from all of the processors and puts it back together for - !! the entire computational domain on the rank 0 processor. - !! This is only done for 1D simulations. - !! @param q_sf Flow variable defined on a single computational sub-domain - !! @param q_root_sf Flow variable defined on the entire computational domain + !> This subroutine gathers the sub-domain flow variable data from all of the processors and puts it back together for the entire + !! computational domain on the rank 0 processor. This is only done for 1D simulations. + !! @param q_sf Flow variable defined on a single computational sub-domain + !! @param q_root_sf Flow variable defined on the entire computational domain impure subroutine s_mpi_defragment_1d_flow_variable(q_sf, q_root_sf) - - real(wp), dimension(0:m), intent(in) :: q_sf + real(wp), dimension(0:m), intent(in) :: q_sf real(wp), dimension(0:m), intent(inout) :: q_root_sf #ifdef MFC_MPI @@ -390,17 +293,11 @@ contains ! Gathering the sub-domain flow variable data from all the processes ! and putting it back together for the entire computational domain ! on the process with rank 0 - call MPI_GATHERV(q_sf(0), m + 1, mpi_p, & - q_root_sf(0), recvcounts, displs, & - mpi_p, 0, MPI_COMM_WORLD, ierr) - + call MPI_GATHERV(q_sf(0), m + 1, mpi_p, q_root_sf(0), recvcounts, displs, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif - end subroutine s_mpi_defragment_1d_flow_variable - !> Deallocation procedures for the module impure subroutine s_finalize_mpi_proxy_module - #ifdef MFC_MPI ! Deallocating the receive counts and the displacement vector @@ -409,9 +306,6 @@ contains deallocate (recvcounts) deallocate (displs) end if - #endif - end subroutine s_finalize_mpi_proxy_module - end module m_mpi_proxy diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 7ae3dbfebe..c61abed4a3 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -7,7 +7,6 @@ !> @brief Reads and validates user inputs, allocates variables, and configures MPI decomposition and I/O for post-processing module m_start_up - ! Dependencies use, intrinsic :: iso_c_binding @@ -55,26 +54,23 @@ module m_start_up include 'fftw3.f03' - type(c_ptr) :: fwd_plan_x, fwd_plan_y, fwd_plan_z - complex(c_double_complex), allocatable :: data_in(:), data_out(:) - complex(c_double_complex), allocatable :: data_cmplx(:, :, :), data_cmplx_y(:, :, :), data_cmplx_z(:, :, :) - real(wp), allocatable, dimension(:, :, :) :: En_real - real(wp), allocatable, dimension(:) :: En - integer :: num_procs_x, num_procs_y, num_procs_z - integer :: Nx, Ny, Nz, Nxloc, Nyloc, Nyloc2, Nzloc, Nf - integer :: ierr - integer :: MPI_COMM_CART, MPI_COMM_CART12, MPI_COMM_CART13 - integer, dimension(3) :: cart3d_coords - integer, dimension(2) :: cart2d12_coords, cart2d13_coords - integer :: proc_rank12, proc_rank13 - + type(c_ptr) :: fwd_plan_x, fwd_plan_y, fwd_plan_z + complex(c_double_complex), allocatable :: data_in(:), data_out(:) + complex(c_double_complex), allocatable :: data_cmplx(:,:,:), data_cmplx_y(:,:,:), data_cmplx_z(:,:,:) + real(wp), allocatable, dimension(:,:,:) :: En_real + real(wp), allocatable, dimension(:) :: En + integer :: num_procs_x, num_procs_y, num_procs_z + integer :: Nx, Ny, Nz, Nxloc, Nyloc, Nyloc2, Nzloc, Nf + integer :: ierr + integer :: MPI_COMM_CART, MPI_COMM_CART12, MPI_COMM_CART13 + integer, dimension(3) :: cart3d_coords + integer, dimension(2) :: cart2d12_coords, cart2d13_coords + integer :: proc_rank12, proc_rank13 contains - !> Reads the configuration file post_process.inp, in order - !! to populate parameters in module m_global_parameters.f90 - !! with the user provided inputs + !> Reads the configuration file post_process.inp, in order to populate parameters in module m_global_parameters.f90 with the + !! user provided inputs impure subroutine s_read_input_file - character(LEN=name_len) :: file_loc !< !! Generic string used to store the address of a particular file @@ -88,35 +84,18 @@ contains character(len=1000) :: line ! Namelist for all of the parameters to be inputted by the user - namelist /user_inputs/ case_dir, m, n, p, t_step_start, & - t_step_stop, t_step_save, model_eqns, & - num_fluids, mpp_lim, & - weno_order, bc_x, & - bc_y, bc_z, fluid_pp, bub_pp, format, precision, & - output_partial_domain, x_output, y_output, z_output, & - hypoelasticity, G, mhd, & - chem_wrt_Y, chem_wrt_T, avg_state, & - alpha_rho_wrt, rho_wrt, mom_wrt, vel_wrt, & - E_wrt, fft_wrt, pres_wrt, alpha_wrt, gamma_wrt, & - heat_ratio_wrt, pi_inf_wrt, pres_inf_wrt, & - cons_vars_wrt, prim_vars_wrt, c_wrt, & - omega_wrt, qm_wrt, liutex_wrt, schlieren_wrt, schlieren_alpha, & - fd_order, mixture_err, alt_soundspeed, & - flux_lim, flux_wrt, cyl_coord, & - parallel_io, rhoref, pref, bubbles_euler, qbmm, sigR, & - R0ref, nb, polytropic, thermal, Ca, Web, Re_inv, & - polydisperse, poly_sigma, file_per_process, relax, & - relax_model, cf_wrt, sigma, adv_n, ib, num_ibs, & - cfl_adap_dt, cfl_const_dt, t_save, t_stop, n_start, & - cfl_target, surface_tension, bubbles_lagrange, & - sim_data, hyperelasticity, Bx0, relativity, cont_damage, hyper_cleaning, & - num_bc_patches, igr, igr_order, down_sample, recon_type, & - muscl_order, lag_header, lag_txt_wrt, lag_db_wrt, & - lag_id_wrt, lag_pos_wrt, lag_pos_prev_wrt, lag_vel_wrt, & - lag_rad_wrt, lag_rvel_wrt, lag_r0_wrt, lag_rmax_wrt, & - lag_rmin_wrt, lag_dphidt_wrt, lag_pres_wrt, lag_mv_wrt, & - lag_mg_wrt, lag_betaT_wrt, lag_betaC_wrt, & - alpha_rho_e_wrt, ib_state_wrt + namelist /user_inputs/ case_dir, m, n, p, t_step_start, t_step_stop, t_step_save, model_eqns, num_fluids, mpp_lim, & + & weno_order, bc_x, bc_y, bc_z, fluid_pp, bub_pp, format, precision, output_partial_domain, x_output, y_output, & + & z_output, hypoelasticity, G, mhd, chem_wrt_Y, chem_wrt_T, avg_state, alpha_rho_wrt, rho_wrt, mom_wrt, vel_wrt, & + & E_wrt, fft_wrt, pres_wrt, alpha_wrt, gamma_wrt, heat_ratio_wrt, pi_inf_wrt, pres_inf_wrt, cons_vars_wrt, & + & prim_vars_wrt, c_wrt, omega_wrt, qm_wrt, liutex_wrt, schlieren_wrt, schlieren_alpha, fd_order, mixture_err, & + & alt_soundspeed, flux_lim, flux_wrt, cyl_coord, parallel_io, rhoref, pref, bubbles_euler, qbmm, sigR, R0ref, nb, & + & polytropic, thermal, Ca, Web, Re_inv, polydisperse, poly_sigma, file_per_process, relax, relax_model, cf_wrt, & + & sigma, adv_n, ib, num_ibs, cfl_adap_dt, cfl_const_dt, t_save, t_stop, n_start, cfl_target, surface_tension, & + & bubbles_lagrange, sim_data, hyperelasticity, Bx0, relativity, cont_damage, hyper_cleaning, num_bc_patches, igr, & + & igr_order, down_sample, recon_type, muscl_order, lag_header, lag_txt_wrt, lag_db_wrt, lag_id_wrt, lag_pos_wrt, & + & lag_pos_prev_wrt, lag_vel_wrt, lag_rad_wrt, lag_rvel_wrt, lag_r0_wrt, lag_rmax_wrt, lag_rmin_wrt, lag_dphidt_wrt, & + & lag_pres_wrt, lag_mv_wrt, lag_mg_wrt, lag_betaT_wrt, lag_betaC_wrt, alpha_rho_e_wrt, ib_state_wrt ! Inquiring the status of the post_process.inp file file_loc = 'post_process.inp' @@ -125,16 +104,14 @@ contains ! Checking whether the input file is there. If it is, the input file ! is read. If not, the program is terminated. if (file_check) then - open (1, FILE=trim(file_loc), FORM='formatted', & - STATUS='old', ACTION='read') + open (1, FILE=trim(file_loc), form='formatted', STATUS='old', ACTION='read') read (1, NML=user_inputs, iostat=iostatus) if (iostatus /= 0) then backspace (1) read (1, fmt='(A)') line - print *, 'Invalid line in namelist: '//trim(line) - call s_mpi_abort('Invalid line in post_process.inp. It is '// & - 'likely due to a datatype mismatch. Exiting.') + print *, 'Invalid line in namelist: ' // trim(line) + call s_mpi_abort('Invalid line in post_process.inp. It is ' // 'likely due to a datatype mismatch. Exiting.') end if close (1) @@ -156,23 +133,16 @@ contains if (cfl_adap_dt .or. cfl_const_dt) cfl_dt = .true. - if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == -17) .or. & - num_bc_patches > 0) then + if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == -17) .or. num_bc_patches > 0) then bc_io = .true. end if - else call s_mpi_abort('File post_process.inp is missing. Exiting.') end if - end subroutine s_read_input_file - - !> Checking that the user inputs make sense, i.e. that the - !! individual choices are compatible with the code's options - !! and that the combination of these choices results into a - !! valid configuration for the post-process + !> Checking that the user inputs make sense, i.e. that the individual choices are compatible with the code's options and that + !! the combination of these choices results into a valid configuration for the post-process impure subroutine s_check_input_file - character(LEN=len_trim(case_dir)) :: file_loc !< !! Generic string used to store the address of a particular file @@ -182,36 +152,27 @@ contains ! Checking the existence of the case folder case_dir = adjustl(case_dir) - file_loc = trim(case_dir)//'/.' + file_loc = trim(case_dir) // '/.' call my_inquire(file_loc, dir_check) ! Constraint on the location of the case directory if (dir_check .neqv. .true.) then - call s_mpi_abort('Unsupported choice for the value of '// & - 'case_dir. Exiting.') + call s_mpi_abort('Unsupported choice for the value of ' // 'case_dir. Exiting.') end if call s_check_inputs_common() call s_check_inputs() - end subroutine s_check_input_file - !> @brief Load grid and conservative data for a time step, fill ghost-cell buffers, and convert to primitive variables. impure subroutine s_perform_time_step(t_step) - integer, intent(inout) :: t_step if (proc_rank == 0) then if (cfl_dt) then print '(" [", I3, "%] Saving ", I8, " of ", I0, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', & - int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), & - t_step, n_save, wall_time_avg, wall_time + & int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), t_step, n_save, wall_time_avg, wall_time else - print '(" [", I3, "%] Saving ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', & - int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & - (t_step - t_step_start)/t_step_save + 1, & - (t_step_stop - t_step_start)/t_step_save + 1, & - t_step, wall_time_avg, wall_time + print '(" [", I3, "%] Saving ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), (t_step - t_step_start)/t_step_save + 1, (t_step_stop - t_step_start)/t_step_save + 1, t_step, wall_time_avg, wall_time end if end if @@ -229,27 +190,22 @@ contains ! Converting the conservative variables to the primitive ones call s_convert_conservative_to_primitive_variables(q_cons_vf, q_T_sf, q_prim_vf, idwbuff) - end subroutine s_perform_time_step - !> @brief Derive requested flow quantities from primitive variables and write them to the formatted database files. impure subroutine s_save_data(t_step, varname, pres, c, H) - - integer, intent(inout) :: t_step + integer, intent(inout) :: t_step character(LEN=name_len), intent(inout) :: varname - real(wp), intent(inout) :: pres, c, H - real(wp) :: theta1, theta2 - real(wp), dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end) :: liutex_mag - real(wp), dimension(-offset_x%beg:m + offset_x%end, & - -offset_y%beg:n + offset_y%end, & - -offset_z%beg:p + offset_z%end, 3) :: liutex_axis - integer :: i, j, k, l, kx, ky, kz, kf, j_glb, k_glb, l_glb - real(wp) :: En_tot + real(wp), intent(inout) :: pres, c, H + real(wp) :: theta1, theta2 + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, & + & -offset_z%beg:p + offset_z%end) :: liutex_mag + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, & + & 3) :: liutex_axis + integer :: i, j, k, l, kx, ky, kz, kf, j_glb, k_glb, l_glb + real(wp) :: En_tot character(50) :: filename, dirname - logical :: file_exists, dir_exists - integer :: x_beg, x_end, y_beg, y_end, z_beg, z_end + logical :: file_exists, dir_exists + integer :: x_beg, x_end, y_beg, y_end, z_beg, z_end if (output_partial_domain) then call s_define_output_region @@ -286,30 +242,24 @@ contains ! Computing centered finite-difference coefficients in x-direction 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_coeff_x, buff_size, fd_number, fd_order, offset_x) end if ! Computing centered finite-difference coefficients in y-direction 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_coeff_y, buff_size, fd_number, fd_order, offset_y) end if ! Computing centered finite-difference coefficients in z-direction 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_coeff_z, buff_size, fd_number, fd_order, offset_z) end if ! Adding the partial densities to the formatted database file if ((model_eqns == 2) .or. (model_eqns == 3) .or. (model_eqns == 4)) 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) + q_sf(:,:,:) = q_cons_vf(i)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) if (model_eqns /= 4) then write (varname, '(A,I0)') 'alpha_rho', i else @@ -318,14 +268,13 @@ contains call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' - end if end do end if ! Adding the density to the formatted database file if ((rho_wrt .or. (model_eqns == 1 .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) + 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) @@ -333,7 +282,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) + 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) @@ -343,7 +292,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) + 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) @@ -353,24 +302,22 @@ contains ! Adding the momentum to the formatted database file do i = 1, E_idx - mom_idx%beg if (mom_wrt(i) .or. cons_vars_wrt) then - q_sf(:, :, :) = q_cons_vf(i + cont_idx%end)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(i + cont_idx%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) varname(:) = ' ' - end if end do ! Adding the velocity to the formatted database file do i = 1, E_idx - mom_idx%beg if (vel_wrt(i) .or. prim_vars_wrt) then - q_sf(:, :, :) = q_prim_vf(i + cont_idx%end)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(i + cont_idx%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) varname(:) = ' ' - end if end do @@ -378,17 +325,16 @@ contains if (chemistry) then do i = 1, num_species if (chem_wrt_Y(i) .or. prim_vars_wrt) then - q_sf(:, :, :) = q_prim_vf(chemxb + i - 1)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(chemxb + 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) varname(:) = ' ' - end if 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) + 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) @@ -399,7 +345,6 @@ contains ! Adding the flux limiter function to the formatted database file do i = 1, E_idx - mom_idx%beg if (flux_wrt(i)) then - call s_derive_flux_limiter(i, q_prim_vf, q_sf) write (varname, '(A,I0)') 'flux', i @@ -411,12 +356,11 @@ contains ! Adding the energy to the formatted database file if (E_wrt .or. cons_vars_wrt) then - q_sf(:, :, :) = q_cons_vf(E_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(E_idx)%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) varname(:) = ' ' - end if ! Adding the individual energies to the formatted database file @@ -432,9 +376,8 @@ contains end do end if - !Adding Energy cascade FFT + ! Adding Energy cascade FFT if (fft_wrt) then - do l = 0, p do k = 0, n do j = 0, m @@ -450,7 +393,8 @@ contains do l = 0, p do k = 0, n do j = 0, m - data_cmplx(j + 1, k + 1, l + 1) = cmplx(q_cons_vf(mom_idx%beg + 1)%sf(j, k, l)/q_cons_vf(1)%sf(j, k, l), 0._wp) + data_cmplx(j + 1, k + 1, l + 1) = cmplx(q_cons_vf(mom_idx%beg + 1)%sf(j, k, l)/q_cons_vf(1)%sf(j, k, l), & + & 0._wp) end do end do end do @@ -462,7 +406,8 @@ contains do l = 0, p do k = 0, n do j = 0, m - data_cmplx(j + 1, k + 1, l + 1) = cmplx(q_cons_vf(mom_idx%beg + 2)%sf(j, k, l)/q_cons_vf(1)%sf(j, k, l), 0._wp) + data_cmplx(j + 1, k + 1, l + 1) = cmplx(q_cons_vf(mom_idx%beg + 2)%sf(j, k, l)/q_cons_vf(1)%sf(j, k, l), & + & 0._wp) end do end do end do @@ -478,7 +423,6 @@ contains do l = 1, Nz do k = 1, Nyloc2 do j = 1, Nxloc - j_glb = j + cart3d_coords(2)*Nxloc k_glb = k + cart3d_coords(3)*Nyloc2 l_glb = l @@ -504,7 +448,6 @@ contains kf = nint(sqrt(kx**2._wp + ky**2._wp + kz**2._wp)) + 1 En(kf) = En(kf) + En_real(j, k, l) - end do end do end do @@ -537,13 +480,12 @@ contains end if end if end do - end if ! Adding the magnetic field to the formatted database file if (mhd .and. prim_vars_wrt) then do i = B_idx%beg, B_idx%end - q_sf(:, :, :) = q_prim_vf(i)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + 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 @@ -556,7 +498,7 @@ contains else if (i == B_idx%beg) then write (varname, '(A)') 'Bx' - elseif (i == B_idx%beg + 1) then + else if (i == B_idx%beg + 1) then write (varname, '(A)') 'By' else write (varname, '(A)') 'Bz' @@ -572,7 +514,7 @@ contains if (elasticity) then do i = 1, stress_idx%end - stress_idx%beg + 1 if (prim_vars_wrt) then - q_sf(:, :, :) = q_prim_vf(i - 1 + stress_idx%beg)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(i - 1 + stress_idx%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 @@ -583,7 +525,7 @@ contains if (hyperelasticity) then do i = 1, xiend - xibeg + 1 if (prim_vars_wrt) then - q_sf(:, :, :) = q_prim_vf(i - 1 + xibeg)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(i - 1 + xibeg)%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 @@ -592,7 +534,7 @@ contains end if if (cont_damage) then - q_sf(:, :, :) = q_cons_vf(damage_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(damage_idx)%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) @@ -609,33 +551,26 @@ contains ! Adding the pressure to the formatted database file if (pres_wrt .or. prim_vars_wrt) then - q_sf(:, :, :) = q_prim_vf(E_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(E_idx)%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) varname(:) = ' ' - end if ! Adding the volume fraction(s) to the formatted database file - if (((model_eqns == 2) .and. (bubbles_euler .neqv. .true.)) & - .or. (model_eqns == 3) & - ) then - + if (((model_eqns == 2) .and. (bubbles_euler .neqv. .true.)) .or. (model_eqns == 3)) 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 + E_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(i + E_idx)%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) varname(:) = ' ' - end if end do - if (alpha_wrt(num_fluids) & - .or. & - (cons_vars_wrt .or. prim_vars_wrt)) then + if (alpha_wrt(num_fluids) .or. (cons_vars_wrt .or. prim_vars_wrt)) then if (igr) then do k = z_beg, z_end do j = y_beg, y_end @@ -648,63 +583,51 @@ contains end do end do else - q_sf(:, :, :) = q_cons_vf(adv_idx%end)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(adv_idx%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) varname(:) = ' ' - end if - end if ! Adding specific heat ratio function to formatted database file - if (gamma_wrt & - .or. & - (model_eqns == 1 .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) + if (gamma_wrt .or. (model_eqns == 1 .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) write (varname, '(A)') 'gamma' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' - end if ! Adding the specific heat ratio to the formatted database file if (heat_ratio_wrt) then - call s_derive_specific_heat_ratio(q_sf) write (varname, '(A)') 'heat_ratio' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' - end if ! Adding liquid stiffness function to formatted database file - if (pi_inf_wrt & - .or. & - (model_eqns == 1 .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) + if (pi_inf_wrt .or. (model_eqns == 1 .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) write (varname, '(A)') 'pi_inf' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' - end if ! Adding the liquid stiffness to the formatted database file if (pres_inf_wrt) then - call s_derive_liquid_stiffness(q_sf) write (varname, '(A)') 'pres_inf' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' - end if ! Adding the sound speed to the formatted database file @@ -718,12 +641,10 @@ contains pres = q_prim_vf(E_idx)%sf(i, j, k) - H = ((gamma_sf(i, j, k) + 1._wp)*pres + & - pi_inf_sf(i, j, k) + qv_sf(i, j, k))/rho_sf(i, j, k) + H = ((gamma_sf(i, j, k) + 1._wp)*pres + pi_inf_sf(i, j, k) + qv_sf(i, j, k))/rho_sf(i, j, k) - 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)) + 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 end do @@ -734,13 +655,11 @@ contains call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' - end if ! Adding the vorticity to the formatted database file do i = 1, 3 if (omega_wrt(i)) then - call s_derive_vorticity_component(i, q_prim_vf, q_sf) write (varname, '(A,I0)') 'omega', i @@ -751,7 +670,8 @@ 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)) + 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 @@ -768,7 +688,6 @@ contains ! Adding Liutex magnitude to the formatted database file if (liutex_wrt) then - ! Compute Liutex vector and its magnitude call s_derive_liutex(q_prim_vf, liutex_mag, liutex_axis) @@ -782,41 +701,37 @@ contains ! Liutex axis do i = 1, 3 - q_sf = liutex_axis(:, :, :, i) + q_sf = liutex_axis(:,:,:, i) write (varname, '(A,I0)') 'liutex_axis', i call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' end do - end if ! Adding numerical Schlieren function to formatted database file if (schlieren_wrt) then - call s_derive_numerical_schlieren_function(q_cons_vf, q_sf) write (varname, '(A)') 'schlieren' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' - end if ! Adding the color function to formatted database file if (cf_wrt) then - q_sf(:, :, :) = q_cons_vf(c_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(c_idx)%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(:) = ' ' - end if ! Adding the volume fraction(s) to the formatted database file if (bubbles_euler) then do i = adv_idx%beg, adv_idx%end - q_sf(:, :, :) = q_cons_vf(i)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + 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 - E_idx call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -825,33 +740,33 @@ contains ! Adding the bubble variables to the formatted database file if (bubbles_euler) then - !nR + ! nR do i = 1, nb - q_sf(:, :, :) = q_cons_vf(bub_idx%rs(i))%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(bub_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(:) = ' ' end do - !nRdot + ! nRdot do i = 1, nb - q_sf(:, :, :) = q_cons_vf(bub_idx%vs(i))%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(bub_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(:) = ' ' end do if ((polytropic .neqv. .true.) .and. (.not. qbmm)) then - !nP + ! nP do i = 1, nb - q_sf(:, :, :) = q_cons_vf(bub_idx%ps(i))%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(bub_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(:) = ' ' end do - !nM + ! nM do i = 1, nb - q_sf(:, :, :) = q_cons_vf(bub_idx%ms(i))%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(bub_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(:) = ' ' @@ -860,7 +775,7 @@ contains ! number density if (adv_n) then - q_sf(:, :, :) = q_cons_vf(n_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(n_idx)%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(:) = ' ' @@ -870,10 +785,8 @@ contains ! Adding the lagrangian subgrid variables to the formatted database file 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) + 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(:) = ' ' @@ -889,14 +802,12 @@ contains ! Closing the formatted database file call s_close_formatted_database_file() - end subroutine s_save_data - !> @brief Transpose 3-D complex data from x-pencil to y-pencil layout via MPI_Alltoall. subroutine s_mpi_transpose_x2y complex(c_double_complex), allocatable :: sendbuf(:), recvbuf(:) - integer :: dest_rank, src_rank - integer :: i, j, k, l + integer :: dest_rank, src_rank + integer :: i, j, k, l #ifdef MFC_MPI @@ -907,20 +818,22 @@ contains do l = 1, Nzloc do k = 1, Nyloc do j = 1, Nxloc - sendbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + dest_rank*Nxloc*Nyloc*Nzloc) = data_cmplx(j + dest_rank*Nxloc, k, l) + sendbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + dest_rank*Nxloc*Nyloc*Nzloc) = data_cmplx(j & + & + dest_rank*Nxloc, k, l) end do end do end do end do - call MPI_Alltoall(sendbuf, Nxloc*Nyloc*Nzloc, MPI_C_DOUBLE_COMPLEX, & - recvbuf, Nxloc*Nyloc*Nzloc, MPI_C_DOUBLE_COMPLEX, MPI_COMM_CART12, ierr) + call MPI_Alltoall(sendbuf, Nxloc*Nyloc*Nzloc, MPI_C_DOUBLE_COMPLEX, recvbuf, Nxloc*Nyloc*Nzloc, MPI_C_DOUBLE_COMPLEX, & + & MPI_COMM_CART12, ierr) do src_rank = 0, num_procs_y - 1 do l = 1, Nzloc do k = 1, Nyloc do j = 1, Nxloc - data_cmplx_y(j, k + src_rank*Nyloc, l) = recvbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + src_rank*Nxloc*Nyloc*Nzloc) + data_cmplx_y(j, k + src_rank*Nyloc, & + & l) = recvbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + src_rank*Nxloc*Nyloc*Nzloc) end do end do end do @@ -928,16 +841,13 @@ contains deallocate (sendbuf) deallocate (recvbuf) - #endif - end subroutine s_mpi_transpose_x2y - !> @brief Transpose 3-D complex data from y-pencil to z-pencil layout via MPI_Alltoall. subroutine s_mpi_transpose_y2z complex(c_double_complex), allocatable :: sendbuf(:), recvbuf(:) - integer :: dest_rank, src_rank - integer :: j, k, l + integer :: dest_rank, src_rank + integer :: j, k, l #ifdef MFC_MPI @@ -948,20 +858,23 @@ contains do l = 1, Nzloc do j = 1, Nxloc do k = 1, Nyloc2 - sendbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) + dest_rank*Nyloc2*Nxloc*Nzloc) = data_cmplx_y(j, k + dest_rank*Nyloc2, l) + sendbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) + dest_rank*Nyloc2*Nxloc*Nzloc) = data_cmplx_y(j, & + & k + dest_rank*Nyloc2, l) end do end do end do end do - call MPI_Alltoall(sendbuf, Nyloc2*Nxloc*Nzloc, MPI_C_DOUBLE_COMPLEX, & - recvbuf, Nyloc2*Nxloc*Nzloc, MPI_C_DOUBLE_COMPLEX, MPI_COMM_CART13, ierr) + call MPI_Alltoall(sendbuf, Nyloc2*Nxloc*Nzloc, MPI_C_DOUBLE_COMPLEX, recvbuf, Nyloc2*Nxloc*Nzloc, MPI_C_DOUBLE_COMPLEX, & + & MPI_COMM_CART13, ierr) do src_rank = 0, num_procs_z - 1 do l = 1, Nzloc do j = 1, Nxloc do k = 1, Nyloc2 - data_cmplx_z(j, k, l + src_rank*Nzloc) = recvbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) + src_rank*Nyloc2*Nxloc*Nzloc) + data_cmplx_z(j, k, & + & l + src_rank*Nzloc) = recvbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) & + & + src_rank*Nyloc2*Nxloc*Nzloc) end do end do end do @@ -969,11 +882,8 @@ contains deallocate (sendbuf) deallocate (recvbuf) - #endif - end subroutine s_mpi_transpose_y2z - !> @brief Initialize all post-process sub-modules, set up I/O pointers, and prepare FFTW plans and MPI communicators. impure subroutine s_initialize_modules ! Computation of parameters, allocation procedures, and/or any other tasks @@ -1003,7 +913,6 @@ contains #ifdef MFC_MPI if (fft_wrt) then - num_procs_x = (m_glb + 1)/(m + 1) num_procs_y = (n_glb + 1)/(n + 1) num_procs_z = (p_glb + 1)/(p + 1) @@ -1033,35 +942,26 @@ contains inembed(1) = Nx onembed(1) = Nx - fwd_plan_x = fftw_plan_many_dft(1, size_n, Nyloc*Nzloc, & - data_in, inembed, 1, Nx, & - data_out, onembed, 1, Nx, & - FFTW_FORWARD, FFTW_MEASURE) + fwd_plan_x = fftw_plan_many_dft(1, size_n, Nyloc*Nzloc, data_in, inembed, 1, Nx, data_out, onembed, 1, Nx, & + & FFTW_FORWARD, FFTW_MEASURE) size_n(1) = Ny inembed(1) = Ny onembed(1) = Ny - fwd_plan_y = fftw_plan_many_dft(1, size_n, Nxloc*Nzloc, & - data_out, inembed, 1, Ny, & - data_in, onembed, 1, Ny, & - FFTW_FORWARD, FFTW_MEASURE) + fwd_plan_y = fftw_plan_many_dft(1, size_n, Nxloc*Nzloc, data_out, inembed, 1, Ny, data_in, onembed, 1, Ny, & + & FFTW_FORWARD, FFTW_MEASURE) size_n(1) = Nz inembed(1) = Nz onembed(1) = Nz - fwd_plan_z = fftw_plan_many_dft(1, size_n, Nxloc*Nyloc2, & - data_in, inembed, 1, Nz, & - data_out, onembed, 1, Nz, & - FFTW_FORWARD, FFTW_MEASURE) + fwd_plan_z = fftw_plan_many_dft(1, size_n, Nxloc*Nyloc2, data_in, inembed, 1, Nz, data_out, onembed, 1, Nz, & + & FFTW_FORWARD, FFTW_MEASURE) - call MPI_CART_CREATE(MPI_COMM_WORLD, 3, (/num_procs_x, & - num_procs_y, num_procs_z/), & - (/.true., .true., .true./), & - .false., MPI_COMM_CART, ierr) - call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, & - cart3d_coords, ierr) + call MPI_CART_CREATE(MPI_COMM_WORLD, 3, (/num_procs_x, num_procs_y, num_procs_z/), (/.true., .true., .true./), & + & .false., MPI_COMM_CART, ierr) + call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, cart3d_coords, ierr) call MPI_Cart_SUB(MPI_COMM_CART, (/.true., .true., .false./), MPI_COMM_CART12, ierr) call MPI_COMM_RANK(MPI_COMM_CART12, proc_rank12, ierr) @@ -1070,14 +970,11 @@ contains call MPI_Cart_SUB(MPI_COMM_CART, (/.true., .false., .true./), MPI_COMM_CART13, ierr) call MPI_COMM_RANK(MPI_COMM_CART13, proc_rank13, ierr) call MPI_CART_COORDS(MPI_COMM_CART13, proc_rank13, 2, cart2d13_coords, ierr) - end if #endif end subroutine s_initialize_modules - !> @brief Perform a distributed forward 3-D FFT using pencil decomposition with FFTW and MPI transposes. subroutine s_mpi_FFT_fwd - integer :: j, k, l #ifdef MFC_MPI @@ -1139,14 +1036,10 @@ contains end do end do end do - #endif - end subroutine s_mpi_FFT_fwd - !> @brief Set up the MPI environment, read and broadcast user inputs, and decompose the computational domain. impure subroutine s_initialize_mpi_domain - num_dims = 1 + min(1, n) + min(1, p) ! Initialization of the MPI environment @@ -1171,18 +1064,16 @@ contains call s_initialize_parallel_io() call s_mpi_decompose_computational_domain() call s_check_inputs_fft() - end subroutine s_initialize_mpi_domain - !> @brief Destroy FFTW plans, free MPI communicators, and finalize all post-process sub-modules. impure subroutine s_finalize_modules ! Disassociate pointers for serial and parallel I/O s_read_data_files => null() -! if (sim_data .and. proc_rank == 0) then -! call s_close_intf_data_file() -! call s_close_energy_data_file() -! end if + ! if (sim_data .and. proc_rank == 0) then + ! call s_close_intf_data_file() + ! call s_close_energy_data_file() + ! end if if (fft_wrt) then if (c_associated(fwd_plan_x)) call fftw_destroy_plan(fwd_plan_x) @@ -1220,5 +1111,4 @@ contains ! Finalizing the MPI environment call s_mpi_finalize() end subroutine s_finalize_modules - end module m_start_up diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index c325b649da..854b5475f4 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -2,23 +2,17 @@ !! @file !! @brief Contains program p_main -!> @brief The post-process restructures raw unformatted data, outputted by -!! the simulation, into a formatted database, Silo-HDF5 or Binary, -!! chosen by the user. The user may also specify which variables to -!! include in the database. The choices range from any one of the -!! primitive and conservative variables, as well as quantities that -!! can be derived from those such as the unadvected volume fraction, -!! specific heat ratio, liquid stiffness, speed of sound, vorticity -!! and the numerical Schlieren function. +!> @brief The post-process restructures raw unformatted data, outputted by the simulation, into a formatted database, Silo-HDF5 or +!! Binary, chosen by the user. The user may also specify which variables to include in the database. The choices range from any one +!! of the primitive and conservative variables, as well as quantities that can be derived from those such as the unadvected volume +!! fraction, specific heat ratio, liquid stiffness, speed of sound, vorticity and the numerical Schlieren function. program p_main - use m_global_parameters !< Global parameters for the code use m_start_up implicit none - integer :: t_step !< Iterator for the main time-stepping loop - + integer :: t_step !< Iterator for the main time-stepping loop character(LEN=name_len) :: varname !< !! Generic storage for the name(s) of the flow variable(s) that will be added !! to the formatted database file(s) @@ -42,7 +36,6 @@ program p_main ! Time-Marching Loop do - ! If all time-steps are not ready to be post-processed and one rank is ! faster than another, the slower rank processing the last available ! step might be killed when the faster rank attempts to process the @@ -78,7 +71,7 @@ program p_main ! case that it is not needed, the post-processor is done and may exit. if ((t_step_stop - t_step) < t_step_save .and. t_step_stop /= t_step) then t_step = t_step_stop - t_step_save - elseif (t_step == t_step_stop) then + else if (t_step == t_step_stop) then exit end if end if @@ -89,7 +82,6 @@ program p_main ! Incrementing time-step iterator to next time-step to be post-processed t_step = t_step + t_step_save end if - end do ! END: Time-Marching Loop @@ -100,5 +92,4 @@ program p_main close (11) call s_finalize_modules() - end program p_main diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index bfb6f9d159..bfe1bc32d3 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -7,12 +7,11 @@ !> @brief Assigns initial primitive variables to computational cells based on patch geometry module m_assign_variables + use m_derived_types ! Definitions of the derived types - use m_derived_types ! Definitions of the derived types + use m_global_parameters ! Global parameters for the code - use m_global_parameters ! Global parameters for the code - - use m_variables_conversion ! Subroutines to change the state variables from + use m_variables_conversion ! Subroutines to change the state variables from use m_helper_basic !< Functions to compare floating point numbers @@ -24,19 +23,15 @@ module m_assign_variables type(scalar_field) :: alf_sum - procedure(s_assign_patch_xxxxx_primitive_variables), & - pointer :: s_assign_patch_primitive_variables => null() !< + procedure(s_assign_patch_xxxxx_primitive_variables), pointer :: s_assign_patch_primitive_variables => null() !< !! Depending on the multicomponent flow model, this variable is a pointer to !! either the subroutine s_assign_patch_mixture_primitive_variables, or the !! subroutine s_assign_patch_species_primitive_variables - - !> Abstract interface to the two subroutines that assign the patch primitive - !! variables, either mixture or species, depending on the subroutine, to a - !! particular cell in the computational domain + !> Abstract interface to the two subroutines that assign the patch primitive variables, either mixture or species, depending on + !! the subroutine, to a particular cell in the computational domain abstract interface - !> Skeleton of s_assign_patch_mixture_primitive_variables - !! and s_assign_patch_species_primitive_variables + !> Skeleton of s_assign_patch_mixture_primitive_variables and s_assign_patch_species_primitive_variables !! @param patch_id is the patch identifier !! @param j (x) cell index in which the mixture or species primitive variables from the indicated patch are assigned !! @param k (y,th) cell index in which the mixture or species primitive variables from the indicated patch are assigned @@ -44,37 +39,28 @@ module m_assign_variables !! @param eta pseudo volume fraction !! @param q_prim_vf Primitive variables !! @param patch_id_fp Array to track patch ids - subroutine s_assign_patch_xxxxx_primitive_variables(patch_id, j, k, l, & - eta, q_prim_vf, patch_id_fp) - + subroutine s_assign_patch_xxxxx_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) import :: scalar_field, sys_size, n, m, p, wp - integer, intent(in) :: patch_id - integer, intent(in) :: j, k, l - real(wp), intent(in) :: eta + integer, intent(in) :: patch_id + integer, intent(in) :: j, k, l + real(wp), intent(in) :: eta type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif - end subroutine s_assign_patch_xxxxx_primitive_variables - end interface - private; - public :: s_initialize_assign_variables_module, & - s_assign_patch_primitive_variables, & - s_assign_patch_mixture_primitive_variables, & - s_assign_patch_species_primitive_variables, & - s_finalize_assign_variables_module - + private; + public :: s_initialize_assign_variables_module, s_assign_patch_primitive_variables, & + & s_assign_patch_mixture_primitive_variables, s_assign_patch_species_primitive_variables, s_finalize_assign_variables_module contains !> @brief Allocates volume fraction sum and sets the patch primitive variable assignment procedure pointer. impure subroutine s_initialize_assign_variables_module - if (.not. igr) then allocate (alf_sum%sf(0:m, 0:n, 0:p)) end if @@ -83,26 +69,17 @@ contains ! for assignment of the patch mixture or species primitive variables ! to a cell in the domain is targeted by the procedure pointer - if (model_eqns == 1) then ! Gamma/pi_inf model - s_assign_patch_primitive_variables => & - s_assign_patch_mixture_primitive_variables + if (model_eqns == 1) then ! Gamma/pi_inf model + s_assign_patch_primitive_variables => s_assign_patch_mixture_primitive_variables else ! Volume fraction model - s_assign_patch_primitive_variables => & - s_assign_patch_species_primitive_variables + s_assign_patch_primitive_variables => s_assign_patch_species_primitive_variables end if - end subroutine s_initialize_assign_variables_module - - !> This subroutine assigns the mixture primitive variables - !! of the patch designated by the patch_id, to the cell that - !! is designated by the indexes (j,k,l). In addition, the - !! variable bookkeeping the patch identities in the entire - !! domain is updated with the new assignment. Note that if - !! the smoothing of the patch's boundaries is employed, the - !! ensuing primitive variables in the cell will be a type of - !! combination of the current patch's primitive variables - !! with those of the smoothing patch. The specific details - !! of the combination may be found in Shyue's work (1998). + !> This subroutine assigns the mixture primitive variables of the patch designated by the patch_id, to the cell that is + !! designated by the indexes (j,k,l). In addition, the variable bookkeeping the patch identities in the entire domain is updated + !! with the new assignment. Note that if the smoothing of the patch's boundaries is employed, the ensuing primitive variables in + !! the cell will be a type of combination of the current patch's primitive variables with those of the smoothing patch. The + !! specific details of the combination may be found in Shyue's work (1998). !! @param patch_id the patch identifier !! @param j the x-dir node index !! @param k the y-dir node index @@ -110,13 +87,12 @@ contains !! @param eta pseudo volume fraction !! @param q_prim_vf Primitive variables !! @param patch_id_fp Array to track patch ids - subroutine s_assign_patch_mixture_primitive_variables(patch_id, j, k, l, & - eta, q_prim_vf, patch_id_fp) + subroutine s_assign_patch_mixture_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) $:GPU_ROUTINE(parallelism='[seq]') - integer, intent(in) :: patch_id - integer, intent(in) :: j, k, l - real(wp), intent(in) :: eta + integer, intent(in) :: patch_id + integer, intent(in) :: j, k, l + real(wp), intent(in) :: eta type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -125,9 +101,8 @@ contains #endif real(wp) :: Ys(1:num_species) - - integer :: smooth_patch_id - integer :: i !< generic loop operator + integer :: smooth_patch_id + integer :: i !< generic loop operator ! Assigning the mixture primitive variables of a uniform state patch @@ -135,37 +110,25 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id ! Density - q_prim_vf(1)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%rho & - + (1._wp - eta)*patch_icpp(smooth_patch_id)%rho + q_prim_vf(1)%sf(j, k, l) = eta*patch_icpp(patch_id)%rho + (1._wp - eta)*patch_icpp(smooth_patch_id)%rho ! Velocity do i = 1, E_idx - mom_idx%beg - q_prim_vf(i + 1)%sf(j, k, l) = & - 1._wp/q_prim_vf(1)%sf(j, k, l)* & - (eta*patch_icpp(patch_id)%rho & - *patch_icpp(patch_id)%vel(i) & - + (1._wp - eta)*patch_icpp(smooth_patch_id)%rho & - *patch_icpp(smooth_patch_id)%vel(i)) + q_prim_vf(i + 1)%sf(j, k, l) = 1._wp/q_prim_vf(1)%sf(j, k, & + & l)*(eta*patch_icpp(patch_id)%rho*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*patch_icpp(smooth_patch_id) & + & %rho*patch_icpp(smooth_patch_id)%vel(i)) end do ! Specific heat ratio function - q_prim_vf(gamma_idx)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%gamma & - + (1._wp - eta)*patch_icpp(smooth_patch_id)%gamma + q_prim_vf(gamma_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%gamma + (1._wp - eta)*patch_icpp(smooth_patch_id)%gamma ! Pressure - q_prim_vf(E_idx)%sf(j, k, l) = & - 1._wp/q_prim_vf(gamma_idx)%sf(j, k, l)* & - (eta*patch_icpp(patch_id)%gamma & - *patch_icpp(patch_id)%pres & - + (1._wp - eta)*patch_icpp(smooth_patch_id)%gamma & - *patch_icpp(smooth_patch_id)%pres) + q_prim_vf(E_idx)%sf(j, k, l) = 1._wp/q_prim_vf(gamma_idx)%sf(j, k, & + & l)*(eta*patch_icpp(patch_id)%gamma*patch_icpp(patch_id)%pres + (1._wp - eta)*patch_icpp(smooth_patch_id) & + & %gamma*patch_icpp(smooth_patch_id)%pres) ! Liquid stiffness function - q_prim_vf(pi_inf_idx)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%pi_inf & - + (1._wp - eta)*patch_icpp(smooth_patch_id)%pi_inf + q_prim_vf(pi_inf_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%pi_inf + (1._wp - eta)*patch_icpp(smooth_patch_id)%pi_inf ! Species Concentrations if (chemistry) then @@ -175,9 +138,7 @@ contains ! Accumulating the species concentrations sum = 0._wp do i = 1, num_species - term = & - eta*patch_icpp(patch_id)%Y(i) & - + (1._wp - eta)*patch_icpp(smooth_patch_id)%Y(i) + term = eta*patch_icpp(patch_id)%Y(i) + (1._wp - eta)*patch_icpp(smooth_patch_id)%Y(i) q_prim_vf(chemxb + i - 1)%sf(j, k, l) = term sum = sum + term end do @@ -186,8 +147,7 @@ contains ! Normalizing the species concentrations do i = 1, num_species - q_prim_vf(chemxb + i - 1)%sf(j, k, l) = & - q_prim_vf(chemxb + i - 1)%sf(j, k, l)/sum + q_prim_vf(chemxb + i - 1)%sf(j, k, l) = q_prim_vf(chemxb + i - 1)%sf(j, k, l)/sum Ys(i) = q_prim_vf(chemxb + i - 1)%sf(j, k, l) end do end block @@ -195,22 +155,18 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < 1.e-16_wp) patch_id_fp(j, k, l) = patch_id - end subroutine s_assign_patch_mixture_primitive_variables - !> @brief Applies a stable pressure perturbation following Ando's method for bubble-laden flows. !! @param j the x-dir node index !! @param k the y-dir node index !! @param l the z-dir node index !! @param q_prim_vf Primitive variables subroutine s_perturb_primitive(j, k, l, q_prim_vf) - - integer, intent(in) :: j, k, l + integer, intent(in) :: j, k, l type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i - real(wp) :: pres_mag, loc, n_tait, B_tait, p0 - real(wp) :: R3bar, n0, ratio, nH, vfH, velH, rhoH, deno + integer :: i + real(wp) :: pres_mag, loc, n_tait, B_tait, p0 + real(wp) :: R3bar, n0, ratio, nH, vfH, velH, rhoH, deno p0 = 101325._wp pres_mag = 1.e-1_wp @@ -224,7 +180,8 @@ contains if (qbmm) then do i = 1, nb - q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)*((p0 - bub_pp%pv)/(q_prim_vf(E_idx)%sf(j, k, l)*p0 - bub_pp%pv))**(1._wp/3._wp) + q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, & + & l)*((p0 - bub_pp%pv)/(q_prim_vf(E_idx)%sf(j, k, l)*p0 - bub_pp%pv))**(1._wp/3._wp) end do end if @@ -270,12 +227,9 @@ contains end do q_prim_vf(alf_idx)%sf(j, k, l) = vfH - end subroutine s_perturb_primitive - - !> This subroutine assigns the species primitive variables. This follows - !! s_assign_patch_species_primitive_variables with adaptation for - !! ensemble-averaged bubble modeling + !> This subroutine assigns the species primitive variables. This follows s_assign_patch_species_primitive_variables with + !! adaptation for ensemble-averaged bubble modeling !! @param patch_id the patch identifier !! @param j the x-dir node index !! @param k the y-dir node index @@ -283,12 +237,11 @@ contains !! @param eta pseudo volume fraction !! @param q_prim_vf Primitive variables !! @param patch_id_fp Array to track patch ids - impure subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, & - eta, q_prim_vf, patch_id_fp) + impure subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) $:GPU_ROUTINE(parallelism='[seq]') - integer, intent(in) :: patch_id - integer, intent(in) :: j, k, l + integer, intent(in) :: patch_id + integer, intent(in) :: j, k, l real(wp), intent(in) :: eta #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -300,22 +253,20 @@ contains ! Density, the specific heat ratio function and the liquid stiffness ! function, respectively, obtained from the combination of primitive ! variables of the current and smoothing patches - real(wp) :: rho !< density - real(wp) :: gamma - real(wp) :: lit_gamma !< specific heat ratio - real(wp) :: pi_inf !< stiffness from SEOS - real(wp) :: qv !< reference energy from SEOS - real(wp) :: orig_rho - real(wp) :: orig_gamma - real(wp) :: orig_pi_inf - real(wp) :: orig_qv - real(wp) :: muR, muV - real(wp) :: R3bar - real(wp) :: rcoord, theta, phi, xi_sph - real(wp), dimension(3) :: xi_cart - - real(wp) :: Ys(1:num_species) - + real(wp) :: rho !< density + real(wp) :: gamma + real(wp) :: lit_gamma !< specific heat ratio + real(wp) :: pi_inf !< stiffness from SEOS + real(wp) :: qv !< reference energy from SEOS + real(wp) :: orig_rho + real(wp) :: orig_gamma + real(wp) :: orig_pi_inf + real(wp) :: orig_qv + real(wp) :: muR, muV + real(wp) :: R3bar + real(wp) :: rcoord, theta, phi, xi_sph + real(wp), dimension(3) :: xi_cart + real(wp) :: Ys(1:num_species) real(stp), dimension(sys_size) :: orig_prim_vf !< !! Vector to hold original values of cell for smoothing purposes @@ -331,25 +282,20 @@ contains end do if (mpp_lim .and. bubbles_euler) then - !adjust volume fractions, according to modeled gas void fraction + ! adjust volume fractions, according to modeled gas void fraction alf_sum%sf = 0._wp do i = adv_idx%beg, adv_idx%end - 1 alf_sum%sf = alf_sum%sf + q_prim_vf(i)%sf end do do i = adv_idx%beg, adv_idx%end - 1 - q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf) & - /alf_sum%sf + q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf)/alf_sum%sf end do end if ! Computing Mixture Variables from Original Primitive Variables ! call s_convert_species_to_mixture_variables( & - call s_convert_to_mixture_variables( & - q_prim_vf, j, k, l, & - orig_rho, & - orig_gamma, & - orig_pi_inf, orig_qv) + call s_convert_to_mixture_variables(q_prim_vf, j, k, l, orig_rho, orig_gamma, orig_pi_inf, orig_qv) ! Computing Mixture Variables of Current Patch @@ -361,15 +307,14 @@ contains end if if (mpp_lim .and. bubbles_euler) then - !adjust volume fractions, according to modeled gas void fraction + ! adjust volume fractions, according to modeled gas void fraction alf_sum%sf = 0._wp do i = adv_idx%beg, adv_idx%end - 1 alf_sum%sf = alf_sum%sf + q_prim_vf(i)%sf end do do i = adv_idx%beg, adv_idx%end - 1 - q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf) & - /alf_sum%sf + q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf)/alf_sum%sf end do end if @@ -382,12 +327,8 @@ contains ! Density and the specific heat ratio and liquid stiffness functions ! call s_convert_species_to_mixture_variables( & - call s_convert_to_mixture_variables( & - q_prim_vf, j, k, l, & - patch_icpp(patch_id)%rho, & - patch_icpp(patch_id)%gamma, & - patch_icpp(patch_id)%pi_inf, & - patch_icpp(patch_id)%qv) + call s_convert_to_mixture_variables(q_prim_vf, j, k, l, patch_icpp(patch_id)%rho, patch_icpp(patch_id)%gamma, & + & patch_icpp(patch_id)%pi_inf, patch_icpp(patch_id)%qv) ! Computing Mixture Variables of Smoothing Patch @@ -406,15 +347,14 @@ contains end if if (mpp_lim .and. bubbles_euler) then - !adjust volume fractions, according to modeled gas void fraction + ! adjust volume fractions, according to modeled gas void fraction alf_sum%sf = 0._wp do i = adv_idx%beg, adv_idx%end - 1 alf_sum%sf = alf_sum%sf + q_prim_vf(i)%sf end do do i = adv_idx%beg, adv_idx%end - 1 - q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf) & - /alf_sum%sf + q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf)/alf_sum%sf end do end if @@ -462,65 +402,46 @@ contains ! Density and the specific heat ratio and liquid stiffness functions ! call s_convert_species_to_mixture_variables( & - call s_convert_to_mixture_variables( & - q_prim_vf, j, k, l, & - patch_icpp(smooth_patch_id)%rho, & - patch_icpp(smooth_patch_id)%gamma, & - patch_icpp(smooth_patch_id)%pi_inf, & - patch_icpp(smooth_patch_id)%qv) + call s_convert_to_mixture_variables(q_prim_vf, j, k, l, patch_icpp(smooth_patch_id)%rho, & + & patch_icpp(smooth_patch_id)%gamma, patch_icpp(smooth_patch_id)%pi_inf, & + & patch_icpp(smooth_patch_id)%qv) ! Pressure - q_prim_vf(E_idx)%sf(j, k, l) = & - (eta*patch_icpp(patch_id)%pres & - + (1._wp - eta)*orig_prim_vf(E_idx)) + q_prim_vf(E_idx)%sf(j, k, l) = (eta*patch_icpp(patch_id)%pres + (1._wp - eta)*orig_prim_vf(E_idx)) if (.not. igr .or. num_fluids > 1) then ! Volume fractions \alpha do i = adv_idx%beg, adv_idx%end - q_prim_vf(i)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%alpha(i - E_idx) & - + (1._wp - eta)*orig_prim_vf(i) + q_prim_vf(i)%sf(j, k, l) = eta*patch_icpp(patch_id)%alpha(i - E_idx) + (1._wp - eta)*orig_prim_vf(i) end do end if if (mhd) then if (n == 0) then ! 1D: By, Bz - q_prim_vf(B_idx%beg)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%By & - + (1._wp - eta)*orig_prim_vf(B_idx%beg) - q_prim_vf(B_idx%beg + 1)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%Bz & - + (1._wp - eta)*orig_prim_vf(B_idx%beg + 1) + q_prim_vf(B_idx%beg)%sf(j, k, l) = eta*patch_icpp(patch_id)%By + (1._wp - eta)*orig_prim_vf(B_idx%beg) + q_prim_vf(B_idx%beg + 1)%sf(j, k, l) = eta*patch_icpp(patch_id)%Bz + (1._wp - eta)*orig_prim_vf(B_idx%beg + 1) else ! 2D/3D: Bx, By, Bz - q_prim_vf(B_idx%beg)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%Bx & - + (1._wp - eta)*orig_prim_vf(B_idx%beg) - q_prim_vf(B_idx%beg + 1)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%By & - + (1._wp - eta)*orig_prim_vf(B_idx%beg + 1) - q_prim_vf(B_idx%beg + 2)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%Bz & - + (1._wp - eta)*orig_prim_vf(B_idx%beg + 2) + q_prim_vf(B_idx%beg)%sf(j, k, l) = eta*patch_icpp(patch_id)%Bx + (1._wp - eta)*orig_prim_vf(B_idx%beg) + q_prim_vf(B_idx%beg + 1)%sf(j, k, l) = eta*patch_icpp(patch_id)%By + (1._wp - eta)*orig_prim_vf(B_idx%beg + 1) + q_prim_vf(B_idx%beg + 2)%sf(j, k, l) = eta*patch_icpp(patch_id)%Bz + (1._wp - eta)*orig_prim_vf(B_idx%beg + 2) end if end if ! Elastic Shear Stress if (elasticity) then do i = 1, (stress_idx%end - stress_idx%beg) + 1 - q_prim_vf(i + stress_idx%beg - 1)%sf(j, k, l) = & - (eta*patch_icpp(patch_id)%tau_e(i) & - + (1._wp - eta)*orig_prim_vf(i + stress_idx%beg - 1)) + q_prim_vf(i + stress_idx%beg - 1)%sf(j, k, & + & l) = (eta*patch_icpp(patch_id)%tau_e(i) + (1._wp - eta)*orig_prim_vf(i + stress_idx%beg - 1)) end do end if ! Elastic Shear Stress if (hyperelasticity) then - if (pre_stress) then ! pre stressed initial condition in spatial domain rcoord = sqrt((x_cc(j)**2 + y_cc(k)**2 + z_cc(l)**2)) theta = atan2(y_cc(k), x_cc(j)) phi = atan2(sqrt(x_cc(j)**2 + y_cc(k)**2), z_cc(l)) - !spherical coord, assuming Rmax=1 + ! spherical coord, assuming Rmax=1 xi_sph = (rcoord**3 - R0ref**3 + 1._wp)**(1._wp/3._wp) xi_cart(1) = xi_sph*sin(phi)*cos(theta) xi_cart(2) = xi_sph*sin(phi)*sin(theta) @@ -533,54 +454,47 @@ contains ! assigning the reference map to the q_prim vector field do i = 1, num_dims - q_prim_vf(i + xibeg - 1)%sf(j, k, l) = eta*xi_cart(i) + & - (1._wp - eta)*orig_prim_vf(i + xibeg - 1) + q_prim_vf(i + xibeg - 1)%sf(j, k, l) = eta*xi_cart(i) + (1._wp - eta)*orig_prim_vf(i + xibeg - 1) end do end if if (mpp_lim .and. bubbles_euler) then - !adjust volume fractions, according to modeled gas void fraction + ! adjust volume fractions, according to modeled gas void fraction alf_sum%sf = 0._wp do i = adv_idx%beg, adv_idx%end - 1 alf_sum%sf = alf_sum%sf + q_prim_vf(i)%sf end do do i = adv_idx%beg, adv_idx%end - 1 - q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf) & - /alf_sum%sf + q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf)/alf_sum%sf end do end if ! Partial densities \alpha \rho if (model_eqns /= 4) then - !mixture density is an input + ! mixture density is an input do i = 1, cont_idx%end - q_prim_vf(i)%sf(j, k, l) = & - eta*patch_icpp(patch_id)%alpha_rho(i) & - + (1._wp - eta)*orig_prim_vf(i) + q_prim_vf(i)%sf(j, k, l) = eta*patch_icpp(patch_id)%alpha_rho(i) + (1._wp - eta)*orig_prim_vf(i) end do else - !get mixture density from pressure via Tait EOS + ! get mixture density from pressure via Tait EOS pi_inf = pi_infs(1) gamma = gammas(1) lit_gamma = gs_min(1) ! \rho = (( p_l + pi_inf)/( p_ref + pi_inf))**(1/little_gam) * rhoref(1-alf) - q_prim_vf(1)%sf(j, k, l) = & - (((q_prim_vf(E_idx)%sf(j, k, l) + pi_inf)/(pref + pi_inf))**(1/lit_gamma))* & - rhoref*(1 - q_prim_vf(alf_idx)%sf(j, k, l)) + q_prim_vf(1)%sf(j, k, l) = (((q_prim_vf(E_idx)%sf(j, k, & + & l) + pi_inf)/(pref + pi_inf))**(1/lit_gamma))*rhoref*(1 - q_prim_vf(alf_idx)%sf(j, k, l)) end if ! Density and the specific heat ratio and liquid stiffness functions ! call s_convert_species_to_mixture_variables(q_prim_vf, j, k, l, & - call s_convert_to_mixture_variables(q_prim_vf, j, k, l, & - rho, gamma, pi_inf, qv) + call s_convert_to_mixture_variables(q_prim_vf, j, k, l, rho, gamma, pi_inf, qv) ! Velocity do i = 1, E_idx - mom_idx%beg - q_prim_vf(i + cont_idx%end)%sf(j, k, l) = & - (eta*patch_icpp(patch_id)%vel(i) & - + (1._wp - eta)*orig_prim_vf(i + cont_idx%end)) + q_prim_vf(i + cont_idx%end)%sf(j, k, & + & l) = (eta*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*orig_prim_vf(i + cont_idx%end)) end do ! Species Concentrations @@ -591,9 +505,7 @@ contains ! Accumulating the species concentrations sum = 0._wp do i = 1, num_species - term = & - eta*patch_icpp(patch_id)%Y(i) & - + (1._wp - eta)*patch_icpp(smooth_patch_id)%Y(i) + term = eta*patch_icpp(patch_id)%Y(i) + (1._wp - eta)*patch_icpp(smooth_patch_id)%Y(i) q_prim_vf(chemxb + i - 1)%sf(j, k, l) = term sum = sum + term end do @@ -604,8 +516,7 @@ contains ! Normalizing the species concentrations do i = 1, num_species - q_prim_vf(chemxb + i - 1)%sf(j, k, l) = & - q_prim_vf(chemxb + i - 1)%sf(j, k, l)/sum + q_prim_vf(chemxb + i - 1)%sf(j, k, l) = q_prim_vf(chemxb + i - 1)%sf(j, k, l)/sum Ys(i) = q_prim_vf(chemxb + i - 1)%sf(j, k, l) end do end block @@ -613,9 +524,9 @@ contains ! Set streamwise velocity to hyperbolic tangent function of y if (mixlayer_vel_profile) then - q_prim_vf(1 + cont_idx%end)%sf(j, k, l) = & - (eta*patch_icpp(patch_id)%vel(1)*tanh(y_cc(k)*mixlayer_vel_coef) & - + (1._wp - eta)*orig_prim_vf(1 + cont_idx%end)) + q_prim_vf(1 + cont_idx%end)%sf(j, k, & + & l) = (eta*patch_icpp(patch_id)%vel(1)*tanh(y_cc(k)*mixlayer_vel_coef) + (1._wp - eta)*orig_prim_vf(1 & + & + cont_idx%end)) end if ! Set partial pressures to mixture pressure for the 6-eqn model @@ -655,7 +566,6 @@ contains q_prim_vf(bub_idx%ps(i))%sf(j, k, l) = patch_icpp(patch_id)%p0 q_prim_vf(bub_idx%ms(i))%sf(j, k, l) = patch_icpp(patch_id)%m0 end if - end if end do @@ -670,15 +580,14 @@ contains end if if (mpp_lim .and. bubbles_euler) then - !adjust volume fractions, according to modeled gas void fraction + ! adjust volume fractions, according to modeled gas void fraction alf_sum%sf = 0._wp do i = adv_idx%beg, adv_idx%end - 1 alf_sum%sf = alf_sum%sf + q_prim_vf(i)%sf end do do i = adv_idx%beg, adv_idx%end - 1 - q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf) & - /alf_sum%sf + q_prim_vf(i)%sf = q_prim_vf(i)%sf*(1._wp - q_prim_vf(alf_idx)%sf)/alf_sum%sf end do end if @@ -695,8 +604,7 @@ contains end if if (surface_tension) then - q_prim_vf(c_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%cf_val + & - (1._wp - eta)*orig_prim_vf(c_idx) + q_prim_vf(c_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%cf_val + (1._wp - eta)*orig_prim_vf(c_idx) end if ! Updating the patch identities bookkeeping variable @@ -710,17 +618,12 @@ contains ! print *, (bub_idx%rs(i), i = 1, nb) ! print *, (bub_idx%fullmom(i, 1, 0), i = 1, nb) ! end if - end subroutine s_assign_patch_species_primitive_variables - !> @brief Nullifies the patch primitive variable assignment procedure pointer. impure subroutine s_finalize_assign_variables_module - ! Nullifying procedure pointer to the subroutine assigning either ! the patch mixture or species primitive variables to a cell in the ! computational domain s_assign_patch_primitive_variables => null() - end subroutine s_finalize_assign_variables_module - end module m_assign_variables diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index 46cbbda47c..90fa445b2a 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -4,7 +4,6 @@ !> @brief Applies spatially varying boundary condition patches along domain edges and faces module m_boundary_conditions - use m_derived_types use m_global_parameters @@ -19,21 +18,18 @@ module m_boundary_conditions implicit none - real(wp) :: x_centroid, y_centroid, z_centroid - real(wp) :: length_x, length_y, length_z - real(wp) :: radius + real(wp) :: x_centroid, y_centroid, z_centroid + real(wp) :: length_x, length_y, length_z + real(wp) :: radius type(bounds_info) :: x_boundary, y_boundary, z_boundary !< private; public :: s_apply_boundary_patches - contains !> @brief Applies a line-segment boundary condition patch along a domain edge in 2D. impure subroutine s_line_segment_bc(patch_id, bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - integer, intent(in) :: patch_id - - integer :: j + integer, intent(in) :: patch_id + integer :: j ! Patch is a vertical line at x_beg or x_end if (patch_bc(patch_id)%dir == 1) then @@ -74,17 +70,12 @@ contains end if #:endfor end if - end subroutine s_line_segment_bc - !> @brief Applies a circular boundary condition patch on a domain face in 3D. impure subroutine s_circle_bc(patch_id, bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - - integer, intent(in) :: patch_id - - integer :: j, k + integer, intent(in) :: patch_id + integer :: j, k if (patch_bc(patch_id)%dir == 1) then y_centroid = patch_bc(patch_id)%centroid(2) z_centroid = patch_bc(patch_id)%centroid(3) @@ -94,8 +85,7 @@ contains if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_x%${BOUND}$ < 0) then do k = 0, p do j = 0, n - if ((z_cc(k) - z_centroid)**2._wp + & - (y_cc(j) - y_centroid)**2._wp <= radius**2._wp) then + if ((z_cc(k) - z_centroid)**2._wp + (y_cc(j) - y_centroid)**2._wp <= radius**2._wp) then bc_type(1, ${IDX}$)%sf(0, j, k) = patch_bc(patch_id)%type end if end do @@ -112,8 +102,7 @@ contains if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_y%${BOUND}$ < 0) then do k = 0, p do j = 0, m - if ((z_cc(k) - z_centroid)**2._wp + & - (x_cc(j) - x_centroid)**2._wp <= radius**2._wp) then + if ((z_cc(k) - z_centroid)**2._wp + (x_cc(j) - x_centroid)**2._wp <= radius**2._wp) then bc_type(2, ${IDX}$)%sf(j, 0, k) = patch_bc(patch_id)%type end if end do @@ -129,8 +118,7 @@ contains if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_z%${BOUND}$ < 0) then do k = 0, n do j = 0, m - if ((y_cc(k) - y_centroid)**2._wp + & - (x_cc(j) - x_centroid)**2._wp <= radius**2._wp) then + if ((y_cc(k) - y_centroid)**2._wp + (x_cc(j) - x_centroid)**2._wp <= radius**2._wp) then bc_type(3, ${IDX}$)%sf(j, k, 0) = patch_bc(patch_id)%type end if end do @@ -138,16 +126,12 @@ contains end if #:endfor end if - end subroutine s_circle_bc - !> @brief Applies a rectangular boundary condition patch on a domain face in 3D. impure subroutine s_rectangle_bc(patch_id, bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - - integer, intent(in) :: patch_id - integer :: j, k + integer, intent(in) :: patch_id + integer :: j, k if (patch_bc(patch_id)%dir == 1) then y_centroid = patch_bc(patch_id)%centroid(2) z_centroid = patch_bc(patch_id)%centroid(3) @@ -164,10 +148,8 @@ contains if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_x%${BOUND}$ < 0) then do k = 0, p do j = 0, n - if (y_boundary%beg <= y_cc(j) .and. & - y_boundary%end >= y_cc(j) .and. & - z_boundary%beg <= z_cc(k) .and. & - z_boundary%end >= z_cc(k)) then + if (y_boundary%beg <= y_cc(j) .and. y_boundary%end >= y_cc(j) .and. z_boundary%beg <= z_cc(k) & + & .and. z_boundary%end >= z_cc(k)) then bc_type(1, ${IDX}$)%sf(0, j, k) = patch_bc(patch_id)%type end if end do @@ -191,10 +173,8 @@ contains if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_y%${BOUND}$ < 0) then do k = 0, p do j = 0, m - if (x_boundary%beg <= x_cc(j) .and. & - x_boundary%end >= x_cc(j) .and. & - z_boundary%beg <= z_cc(k) .and. & - z_boundary%end >= z_cc(k)) then + if (x_boundary%beg <= x_cc(j) .and. x_boundary%end >= x_cc(j) .and. z_boundary%beg <= z_cc(k) & + & .and. z_boundary%end >= z_cc(k)) then bc_type(2, ${IDX}$)%sf(j, 0, k) = patch_bc(patch_id)%type end if end do @@ -217,10 +197,8 @@ contains if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_z%${BOUND}$ < 0) then do k = 0, n do j = 0, m - if (x_boundary%beg <= x_cc(j) .and. & - x_boundary%end >= x_cc(j) .and. & - y_boundary%beg <= y_cc(k) .and. & - y_boundary%end >= y_cc(k)) then + if (x_boundary%beg <= x_cc(j) .and. x_boundary%end >= x_cc(j) .and. y_boundary%beg <= y_cc(k) & + & .and. y_boundary%end >= y_cc(k)) then bc_type(3, ${IDX}$)%sf(j, k, 0) = patch_bc(patch_id)%type end if end do @@ -228,15 +206,12 @@ contains end if #:endfor end if - end subroutine s_rectangle_bc - !> @brief Iterates over all boundary condition patches and dispatches them by geometry type. impure subroutine s_apply_boundary_patches(q_prim_vf, bc_type) - - type(scalar_field), dimension(sys_size) :: q_prim_vf + type(scalar_field), dimension(sys_size) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2) :: bc_type - integer :: i + integer :: i !< Apply 2D patches to 3D domain if (p > 0) then @@ -247,12 +222,12 @@ contains if (patch_bc(i)%geometry == 2) then call s_circle_bc(i, bc_type) - elseif (patch_bc(i)%geometry == 3) then + else if (patch_bc(i)%geometry == 3) then call s_rectangle_bc(i, bc_type) end if end do !< Apply 1D patches to 2D domain - elseif (n > 0) then + else if (n > 0) then do i = 1, num_bc_patches if (proc_rank == 0) then print *, 'Processing boundary condition patch', i @@ -263,7 +238,5 @@ contains end if end do end if - end subroutine s_apply_boundary_patches - end module m_boundary_conditions diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index ea481d2e91..53a7954cb5 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -7,7 +7,6 @@ #:include 'macros.fpp' module m_check_ib_patches - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters @@ -29,16 +28,14 @@ module m_check_ib_patches implicit none - private; + private; public :: s_check_ib_patches character(len=10) :: iStr - contains !> @brief Validates the geometry parameters of all active and inactive immersed boundary patches. impure subroutine s_check_ib_patches - integer :: i do i = 1, num_patches_max @@ -46,7 +43,7 @@ contains ! call s_check_patch_geometry(i) call s_int_to_str(i, iStr) @:PROHIBIT(patch_ib(i)%geometry == dflt_int, "IB patch undefined. & - patch_ib("//trim(iStr)//")%geometry must be set.") + patch_ib("//trim(iStr)//")%geometry must be set.") ! Constraints on the geometric initial condition patch parameters if (patch_ib(i)%geometry == 2) then @@ -63,266 +60,113 @@ contains call s_check_3d_airfoil_ib_patch_geometry(i) else if (patch_ib(i)%geometry == 10) then call s_check_cylinder_ib_patch_geometry(i) - else if (patch_ib(i)%geometry == 5 .or. & - patch_ib(i)%geometry == 12) then + else if (patch_ib(i)%geometry == 5 .or. patch_ib(i)%geometry == 12) then call s_check_model_ib_patch_geometry(i) else if (patch_ib(i)%geometry == 6) then call s_check_ellipse_ib_patch_geometry(i) else call s_prohibit_abort("Invalid IB patch", & - "patch_ib("//trim(iStr)//")%geometry must be "// & - "2-4, 8-10, 11 or 12.") + & "patch_ib(" // trim(iStr) // ")%geometry must be " // "2-4, 8-10, 11 or 12.") end if else - @:PROHIBIT(patch_ib(i)%geometry /= dflt_int, "Inactive IB patch defined. "// & - "patch_ib("//trim(iStr)//")%geometry must not be set for inactive patches.") + @:PROHIBIT(patch_ib(i)%geometry /= dflt_int, "Inactive IB patch defined. "// "patch_ib("//trim(iStr)//")%geometry must not be set for inactive patches.") call s_check_inactive_ib_patch_geometry(i) end if end do - end subroutine s_check_ib_patches - - !> This subroutine verifies that the geometric parameters of - !! the circle patch have consistently been inputted by the - !! user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the circle patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_circle_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p > 0 & - .or. patch_ib(patch_id)%radius <= 0._wp & - .or. f_is_default(patch_ib(patch_id)%x_centroid) & - .or. f_is_default(patch_ib(patch_id)%y_centroid), & - 'in circle IB patch '//trim(iStr)) - + @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%radius <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in circle IB patch '//trim(iStr)) end subroutine s_check_circle_ib_patch_geometry - - !> This subroutine verifies that the geometric parameters of - !! the ellipse patch have consistently been inputted by the - !! user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the ellipse patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_ellipse_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p > 0 & - .or. patch_ib(patch_id)%length_x <= 0._wp & - .or. patch_ib(patch_id)%length_y <= 0._wp & - .or. f_is_default(patch_ib(patch_id)%x_centroid) & - .or. f_is_default(patch_ib(patch_id)%y_centroid), & - 'in ellipse IB patch '//trim(iStr)) - + @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in ellipse IB patch '//trim(iStr)) end subroutine s_check_ellipse_ib_patch_geometry - - !> This subroutine verifies that the geometric parameters of - !! the airfoil patch have consistently been inputted by the - !! user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the airfoil patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_airfoil_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p > 0 & - .or. patch_ib(patch_id)%c <= 0._wp & - .or. patch_ib(patch_id)%p <= 0._wp & - .or. patch_ib(patch_id)%t <= 0._wp & - .or. patch_ib(patch_id)%m <= 0._wp & - .or. f_is_default(patch_ib(patch_id)%x_centroid) & - .or. f_is_default(patch_ib(patch_id)%y_centroid), & - 'in airfoil IB patch '//trim(iStr)) - + @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id)%p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in airfoil IB patch '//trim(iStr)) end subroutine s_check_airfoil_ib_patch_geometry - - !> This subroutine verifies that the geometric parameters of - !! the 3d airfoil patch have consistently been inputted by the - !! user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the 3d airfoil patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_3d_airfoil_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p == 0 & - .or. patch_ib(patch_id)%c <= 0._wp & - .or. patch_ib(patch_id)%p <= 0._wp & - .or. patch_ib(patch_id)%t <= 0._wp & - .or. patch_ib(patch_id)%m <= 0._wp & - .or. f_is_default(patch_ib(patch_id)%x_centroid) & - .or. f_is_default(patch_ib(patch_id)%y_centroid) & - .or. f_is_default(patch_ib(patch_id)%z_centroid) & - .or. f_is_default(patch_ib(patch_id)%length_z), & - 'in 3d airfoil IB patch '//trim(iStr)) - + @:PROHIBIT(n == 0 .or. p == 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id)%p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. f_is_default(patch_ib(patch_id)%length_z), 'in 3d airfoil IB patch '//trim(iStr)) end subroutine s_check_3d_airfoil_ib_patch_geometry - - !> This subroutine verifies that the geometric parameters of - !! the rectangle patch have consistently been inputted by - !! the user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the rectangle patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_rectangle_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p > 0 & - .or. & - f_is_default(patch_ib(patch_id)%x_centroid) & - .or. & - f_is_default(patch_ib(patch_id)%y_centroid) & - .or. & - patch_ib(patch_id)%length_x <= 0._wp & - .or. & - patch_ib(patch_id)%length_y <= 0._wp, & - 'in rectangle IB patch '//trim(iStr)) - + @:PROHIBIT(n == 0 .or. p > 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp, 'in rectangle IB patch '//trim(iStr)) end subroutine s_check_rectangle_ib_patch_geometry - - !> This subroutine verifies that the geometric parameters of - !! the sphere patch have consistently been inputted by - !! the user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the sphere patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_sphere_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p == 0 & - .or. & - f_is_default(patch_ib(patch_id)%x_centroid) & - .or. & - f_is_default(patch_ib(patch_id)%y_centroid) & - .or. & - f_is_default(patch_ib(patch_id)%z_centroid) & - .or. & - patch_ib(patch_id)%radius <= 0._wp, & - 'in sphere IB patch '//trim(iStr)) - + @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%radius <= 0._wp, 'in sphere IB patch '//trim(iStr)) end subroutine s_check_sphere_ib_patch_geometry - - !> This subroutine verifies that the geometric parameters of - !! the cuboid patch have consistently been inputted by - !! the user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the cuboid patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_cuboid_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p == 0 & - .or. & - f_is_default(patch_ib(patch_id)%x_centroid) & - .or. & - f_is_default(patch_ib(patch_id)%y_centroid) & - .or. & - f_is_default(patch_ib(patch_id)%z_centroid) & - .or. & - patch_ib(patch_id)%length_x <= 0._wp & - .or. & - patch_ib(patch_id)%length_y <= 0._wp & - .or. & - patch_ib(patch_id)%length_z <= 0._wp, & - 'in cuboid IB patch '//trim(iStr)) - + @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. patch_ib(patch_id)%length_z <= 0._wp, 'in cuboid IB patch '//trim(iStr)) end subroutine s_check_cuboid_ib_patch_geometry - - !> This subroutine verifies that the geometric parameters of - !! the cylinder patch have consistently been inputted by - !! the user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the cylinder patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_cylinder_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(p == 0 & - .or. & - f_is_default(patch_ib(patch_id)%x_centroid) & - .or. & - f_is_default(patch_ib(patch_id)%y_centroid) & - .or. & - f_is_default(patch_ib(patch_id)%z_centroid) & - .or. & - (patch_ib(patch_id)%length_x <= 0._wp .and. & - patch_ib(patch_id)%length_y <= 0._wp .and. & - patch_ib(patch_id)%length_z <= 0._wp) & - .or. & - patch_ib(patch_id)%radius <= 0._wp, & - 'in cylinder IB patch '//trim(iStr)) - - @:PROHIBIT( & - (patch_ib(patch_id)%length_x > 0._wp .and. & - ((.not. f_is_default(patch_ib(patch_id)%length_y)) .or. & - (.not. f_is_default(patch_ib(patch_id)%length_z)))) & - .or. & - (patch_ib(patch_id)%length_y > 0._wp .and. & - ((.not. f_is_default(patch_ib(patch_id)%length_x)) .or. & - (.not. f_is_default(patch_ib(patch_id)%length_z)))) & - .or. & - (patch_ib(patch_id)%length_z > 0._wp .and. & - ((.not. f_is_default(patch_ib(patch_id)%length_x)) .or. & - (.not. f_is_default(patch_ib(patch_id)%length_y)))), & - 'in cylinder IB patch '//trim(iStr)) + @:PROHIBIT(p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. (patch_ib(patch_id)%length_x <= 0._wp .and. patch_ib(patch_id)%length_y <= 0._wp .and. patch_ib(patch_id)%length_z <= 0._wp) .or. patch_ib(patch_id)%radius <= 0._wp, 'in cylinder IB patch '//trim(iStr)) + @:PROHIBIT( (patch_ib(patch_id)%length_x > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_y)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id)%length_y > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id)%length_z > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_y)))), 'in cylinder IB patch '//trim(iStr)) end subroutine s_check_cylinder_ib_patch_geometry - - !> This subroutine verifies that the geometric parameters of - !! the model patch have consistently been inputted by - !! the user. - !! @param patch_id Patch identifier + !> This subroutine verifies that the geometric parameters of the model patch have consistently been inputted by the user. + !! @param patch_id Patch identifier impure subroutine s_check_model_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(patch_ib(patch_id)%model_filepath == dflt_char, & - 'Empty model file path for patch '//trim(iStr)) - - @:PROHIBIT(patch_ib(patch_id)%model_scale(1) <= 0._wp & - .or. & - patch_ib(patch_id)%model_scale(2) <= 0._wp & - .or. & - patch_ib(patch_id)%model_scale(3) <= 0._wp, & - 'Negative scale in model IB patch '//trim(iStr)) + @:PROHIBIT(patch_ib(patch_id)%model_filepath == dflt_char, 'Empty model file path for patch '//trim(iStr)) + @:PROHIBIT(patch_ib(patch_id)%model_scale(1) <= 0._wp .or. patch_ib(patch_id)%model_scale(2) <= 0._wp .or. patch_ib(patch_id)%model_scale(3) <= 0._wp, 'Negative scale in model IB patch '//trim(iStr)) end subroutine s_check_model_ib_patch_geometry - !!> This subroutine verifies that the geometric parameters of !! the inactive patch remain unaltered by the user inputs. !! @param patch_id Patch identifier impure subroutine s_check_inactive_ib_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT((.not. f_is_default(patch_ib(patch_id)%x_centroid)) & - .or. & - (.not. f_is_default(patch_ib(patch_id)%y_centroid)) & - .or. & - (.not. f_is_default(patch_ib(patch_id)%z_centroid)) & - .or. & - (.not. f_is_default(patch_ib(patch_id)%length_x)) & - .or. & - (.not. f_is_default(patch_ib(patch_id)%length_y)) & - .or. & - (.not. f_is_default(patch_ib(patch_id)%length_z)) & - .or. & - (.not. f_is_default(patch_ib(patch_id)%radius)), & - 'in inactive IB patch '//trim(iStr)) - + @:PROHIBIT((.not. f_is_default(patch_ib(patch_id)%x_centroid)) .or. (.not. f_is_default(patch_ib(patch_id)%y_centroid)) .or. (.not. f_is_default(patch_ib(patch_id)%z_centroid)) .or. (.not. f_is_default(patch_ib(patch_id)%length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_y)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)) .or. (.not. f_is_default(patch_ib(patch_id)%radius)), 'in inactive IB patch '//trim(iStr)) end subroutine s_check_inactive_ib_patch_geometry - end module m_check_ib_patches diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 6725faba75..67f9b978fd 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -9,7 +9,6 @@ #:include 'macros.fpp' module m_check_patches - ! Dependencies use m_derived_types !< Definitions of the derived types @@ -35,13 +34,11 @@ module m_check_patches private; public :: s_check_patches character(len=10) :: iStr - contains !> @brief Validates the geometry parameters of all active and inactive initial condition patches. impure subroutine s_check_patches - - integer :: i + integer :: i character(len=10) :: num_patches_str call s_int_to_str(num_patches, num_patches_str) @@ -50,52 +47,46 @@ contains if (i <= num_patches) then ! call s_check_patch_geometry(i) call s_int_to_str(i, iStr) - @:PROHIBIT(patch_icpp(i)%geometry == 6, "Invalid patch geometry number. "// & - "patch_icpp("//trim(iStr)//")%geometry is deprecated.") - @:PROHIBIT(patch_icpp(i)%geometry == 7, "Invalid patch geometry number. "// & - "patch_icpp("//trim(iStr)//")%geometry is deprecated.") - @:PROHIBIT(patch_icpp(i)%geometry == 15, "Invalid patch geometry number. "// & - "patch_icpp("//trim(iStr)//")%geometry is deprecated.") - @:PROHIBIT(patch_icpp(i)%geometry == dflt_int, "Invalid patch geometry number. "// & - "patch_icpp("//trim(iStr)//")%geometry must be set.") + @:PROHIBIT(patch_icpp(i)%geometry == 6, "Invalid patch geometry number. "// "patch_icpp("//trim(iStr)//")%geometry is deprecated.") + @:PROHIBIT(patch_icpp(i)%geometry == 7, "Invalid patch geometry number. "// "patch_icpp("//trim(iStr)//")%geometry is deprecated.") + @:PROHIBIT(patch_icpp(i)%geometry == 15, "Invalid patch geometry number. "// "patch_icpp("//trim(iStr)//")%geometry is deprecated.") + @:PROHIBIT(patch_icpp(i)%geometry == dflt_int, "Invalid patch geometry number. "// "patch_icpp("//trim(iStr)//")%geometry must be set.") ! Constraints on the geometric initial condition patch parameters if (patch_icpp(i)%geometry == 1) then call s_check_line_segment_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 2) then + else if (patch_icpp(i)%geometry == 2) then call s_check_circle_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 3) then + else if (patch_icpp(i)%geometry == 3) then call s_check_rectangle_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 4) then + else if (patch_icpp(i)%geometry == 4) then call s_check_line_sweep_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 5) then + else if (patch_icpp(i)%geometry == 5) then call s_check_ellipse_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 8) then + else if (patch_icpp(i)%geometry == 8) then call s_check_sphere_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 9) then + else if (patch_icpp(i)%geometry == 9) then call s_check_cuboid_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 10) then + else if (patch_icpp(i)%geometry == 10) then call s_check_cylinder_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 11) then + else if (patch_icpp(i)%geometry == 11) then call s_check_plane_sweep_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 12) then + else if (patch_icpp(i)%geometry == 12) then call s_check_ellipsoid_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 13) then + else if (patch_icpp(i)%geometry == 13) then call s_check_2d_modal_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 14) then + else if (patch_icpp(i)%geometry == 14) then call s_check_3d_spherical_harmonic_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 20) then + else if (patch_icpp(i)%geometry == 20) then call s_check_2D_TaylorGreen_vortex_patch_geometry(i) - elseif (patch_icpp(i)%geometry == 21) then + else if (patch_icpp(i)%geometry == 21) then call s_check_model_geometry(i) else - call s_prohibit_abort("Invalid patch geometry number", "patch_icpp("//trim(iStr)//")%geometry "// & - "must be between 1 and 21") + call s_prohibit_abort("Invalid patch geometry number", & + & "patch_icpp(" // trim(iStr) // ")%geometry " // "must be between 1 and 21") end if else - @:PROHIBIT(patch_icpp(i)%geometry /= dflt_int, "Inactive patch defined. "// & - "patch_icpp("//trim(iStr)//")%geometry not be set for inactive patches. "// & - "Patch "//trim(iStr)//" is inactive as the number of patches is "//trim(num_patches_str)) + @:PROHIBIT(patch_icpp(i)%geometry /= dflt_int, "Inactive patch defined. "// "patch_icpp("//trim(iStr)//")%geometry not be set for inactive patches. "// "Patch "//trim(iStr)//" is inactive as the number of patches is "//trim(num_patches_str)) call s_check_inactive_patch_geometry(i) end if end do @@ -111,17 +102,10 @@ contains ! Constraints on smoothing initial condition patch parameters do i = 1, num_patches - if (i > 1 .and. (patch_icpp(i)%geometry == 2 .or. & - patch_icpp(i)%geometry == 3 .or. & - patch_icpp(i)%geometry == 4 .or. & - patch_icpp(i)%geometry == 5 .or. & - patch_icpp(i)%geometry == 8 .or. & - patch_icpp(i)%geometry == 9 .or. & - patch_icpp(i)%geometry == 10 .or. & - patch_icpp(i)%geometry == 11 .or. & - patch_icpp(i)%geometry == 12 .or. & - patch_icpp(i)%geometry == 13 .or. & - patch_icpp(i)%geometry == 14)) then + if (i > 1 .and. (patch_icpp(i)%geometry == 2 .or. patch_icpp(i)%geometry == 3 .or. patch_icpp(i) & + & %geometry == 4 .or. patch_icpp(i)%geometry == 5 .or. patch_icpp(i)%geometry == 8 .or. patch_icpp(i) & + & %geometry == 9 .or. patch_icpp(i)%geometry == 10 .or. patch_icpp(i)%geometry == 11 .or. patch_icpp(i) & + & %geometry == 12 .or. patch_icpp(i)%geometry == 13 .or. patch_icpp(i)%geometry == 14)) then call s_check_supported_patch_smoothing(i) else call s_check_unsupported_patch_smoothing(i) @@ -136,13 +120,10 @@ contains call s_check_inactive_patch_primitive_variables(i) end if end do - end subroutine s_check_patches - !> This subroutine checks the line segment patch input - !! @param patch_id Patch identifier + !! @param patch_id Patch identifier impure subroutine s_check_line_segment_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -150,13 +131,10 @@ contains @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Line segment patch "//trim(iStr)//": length_x must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Line segment patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(cyl_coord, "Line segment patch "//trim(iStr)//": cyl_coord is not supported") - end subroutine s_check_line_segment_patch_geometry - - !> This subroutine checks the circle patch input - !! @param patch_id Patch identifier + !> This subroutine checks the circle patch input + !! @param patch_id Patch identifier impure subroutine s_check_circle_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -165,13 +143,10 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "Circle patch "//trim(iStr)//": radius must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Circle patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Circle patch "//trim(iStr)//": y_centroid must be set") - end subroutine s_check_circle_patch_geometry - - !> This subroutine checks the rectangle patch input - !! @param patch_id Patch identifier + !> This subroutine checks the rectangle patch input + !! @param patch_id Patch identifier impure subroutine s_check_rectangle_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -181,13 +156,10 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Rectangle patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Rectangle patch "//trim(iStr)//": length_x must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Rectangle patch "//trim(iStr)//": length_y must be greater than zero") - end subroutine s_check_rectangle_patch_geometry - !> This subroutine checks the line sweep patch input - !! @param patch_id Patch identifier + !! @param patch_id Patch identifier impure subroutine s_check_line_sweep_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -198,13 +170,10 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(1)), "Line sweep patch "//trim(iStr)//": normal(1) must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(2)), "Line sweep patch "//trim(iStr)//": normal(2) must be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%normal(3)), "Line sweep patch "//trim(iStr)//": normal(3) must not be set") - end subroutine s_check_line_sweep_patch_geometry - - !> This subroutine checks the ellipse patch input - !! @param patch_id Patch identifier + !> This subroutine checks the ellipse patch input + !! @param patch_id Patch identifier impure subroutine s_check_ellipse_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -215,13 +184,10 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radii(1) <= 0._wp, "Ellipse patch "//trim(iStr)//": radii(1) must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0._wp, "Ellipse patch "//trim(iStr)//": radii(2) must be greater than zero") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(3)), "Ellipse patch "//trim(iStr)//": radii(3) must not be set") - end subroutine s_check_ellipse_patch_geometry - - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> This subroutine checks the model patch input + !! @param patch_id Patch identifier impure subroutine s_check_2D_TaylorGreen_vortex_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -232,13 +198,10 @@ contains @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Taylor Green vortex patch "//trim(iStr)//": length_x must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Taylor Green vortex patch "//trim(iStr)//": length_y must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%vel(2) <= 0._wp, "Taylor Green vortex patch "//trim(iStr)//": vel(2) must be greater than zero") - end subroutine s_check_2D_TaylorGreen_vortex_patch_geometry - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !! @param patch_id Patch identifier impure subroutine s_check_sphere_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -247,9 +210,7 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Sphere patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Sphere patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Sphere patch "//trim(iStr)//": z_centroid must be set") - end subroutine s_check_sphere_patch_geometry - impure subroutine s_check_2d_modal_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -260,9 +221,7 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "2D modal patch "//trim(iStr)//": radius must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "2D modal patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "2D modal patch "//trim(iStr)//": y_centroid must be set") - end subroutine s_check_2d_modal_patch_geometry - impure subroutine s_check_3d_spherical_harmonic_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -273,13 +232,10 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Spherical harmonic patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Spherical harmonic patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Spherical harmonic patch "//trim(iStr)//": z_centroid must be set") - end subroutine s_check_3d_spherical_harmonic_patch_geometry - - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> This subroutine checks the model patch input + !! @param patch_id Patch identifier impure subroutine s_check_cuboid_patch_geometry(patch_id) - ! Patch identifier integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -291,13 +247,10 @@ contains @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Cuboid patch "//trim(iStr)//": length_x must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Cuboid patch "//trim(iStr)//": length_y must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_z <= 0._wp, "Cuboid patch "//trim(iStr)//": length_z must be greater than zero") - end subroutine s_check_cuboid_patch_geometry - - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> This subroutine checks the model patch input + !! @param patch_id Patch identifier impure subroutine s_check_cylinder_patch_geometry(patch_id) - ! Patch identifier integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -309,25 +262,14 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "Cylinder patch "//trim(iStr)//": radius must be greater than zero") ! Check if exactly one length is defined - @:PROHIBIT(count([ & - patch_icpp(patch_id)%length_x > 0._wp, & - patch_icpp(patch_id)%length_y > 0._wp, & - patch_icpp(patch_id)%length_z > 0._wp & - ]) /= 1, "Cylinder patch "//trim(iStr)//": Exactly one of length_x, length_y, or length_z must be defined and positive") + @:PROHIBIT(count([ patch_icpp(patch_id)%length_x > 0._wp, patch_icpp(patch_id)%length_y > 0._wp, patch_icpp(patch_id)%length_z > 0._wp ]) /= 1, "Cylinder patch "//trim(iStr)//": Exactly one of length_x, length_y, or length_z must be defined and positive") ! Ensure the defined length is positive - @:PROHIBIT( & - (.not. f_is_default(patch_icpp(patch_id)%length_x) .and. patch_icpp(patch_id)%length_x <= 0._wp) .or. & - (.not. f_is_default(patch_icpp(patch_id)%length_y) .and. patch_icpp(patch_id)%length_y <= 0._wp) .or. & - (.not. f_is_default(patch_icpp(patch_id)%length_z) .and. patch_icpp(patch_id)%length_z <= 0._wp), & - "Cylinder patch "//trim(iStr)//": The defined length_{} must be greater than zero") - + @:PROHIBIT( (.not. f_is_default(patch_icpp(patch_id)%length_x) .and. patch_icpp(patch_id)%length_x <= 0._wp) .or. (.not. f_is_default(patch_icpp(patch_id)%length_y) .and. patch_icpp(patch_id)%length_y <= 0._wp) .or. (.not. f_is_default(patch_icpp(patch_id)%length_z) .and. patch_icpp(patch_id)%length_z <= 0._wp), "Cylinder patch "//trim(iStr)//": The defined length_{} must be greater than zero") end subroutine s_check_cylinder_patch_geometry - - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> This subroutine checks the model patch input + !! @param patch_id Patch identifier impure subroutine s_check_plane_sweep_patch_geometry(patch_id) - ! Patch identifier integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -339,13 +281,10 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(1)), "Plane sweep patch "//trim(iStr)//": normal(1) must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(2)), "Plane sweep patch "//trim(iStr)//": normal(2) must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(3)), "Plane sweep patch "//trim(iStr)//": normal(3) must be set") - end subroutine s_check_plane_sweep_patch_geometry - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !! @param patch_id Patch identifier impure subroutine s_check_ellipsoid_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -356,14 +295,11 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radii(1) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(1) must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(2) must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%radii(3) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(3) must be greater than zero") - end subroutine s_check_ellipsoid_patch_geometry - !!> This subroutine verifies that the geometric parameters of !! the inactive patch remain unaltered by the user inputs. !! @param patch_id Patch identifier impure subroutine s_check_inactive_patch_geometry(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -382,172 +318,114 @@ contains @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(1)), "Inactive patch "//trim(iStr)//": radii(1) must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(2)), "Inactive patch "//trim(iStr)//": radii(2) must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(3)), "Inactive patch "//trim(iStr)//": radii(3) must not be set") - end subroutine s_check_inactive_patch_geometry - - !> This subroutine verifies the active patch's right to overwrite the preceding patches - !! @param patch_id Patch identifier + !> This subroutine verifies the active patch's right to overwrite the preceding patches + !! @param patch_id Patch identifier impure subroutine s_check_active_patch_alteration_rights(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(.not. patch_icpp(patch_id)%alter_patch(0), "Patch "//trim(iStr)//": alter_patch(0) must be true") - @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(patch_id:)), "Patch "//trim(iStr)// & - ":alter_patch(i) must be false for i >= "//trim(iStr)//". Only preceding patches can be altered") - + @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(patch_id:)), "Patch "//trim(iStr)// ":alter_patch(i) must be false for i >= "//trim(iStr)//". Only preceding patches can be altered") end subroutine s_check_active_patch_alteration_rights - - !> This subroutine verifies that inactive patches cannot overwrite other patches - !! @param patch_id Patch identifier + !> This subroutine verifies that inactive patches cannot overwrite other patches + !! @param patch_id Patch identifier impure subroutine s_check_inactive_patch_alteration_rights(patch_id) - ! Patch identifier integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(.not. patch_icpp(patch_id)%alter_patch(0), "Inactive patch "//trim(iStr)//": cannot have alter_patch(0) altered") @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(1:)), "Inactive patch "//trim(iStr)//": cannot have any alter_patch(i) enabled") - end subroutine s_check_inactive_patch_alteration_rights - !> This subroutine checks the smoothing parameters - !! @param patch_id Patch identifier + !! @param patch_id Patch identifier impure subroutine s_check_supported_patch_smoothing(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) if (patch_icpp(patch_id)%smoothen) then - @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id >= patch_id, & - "Smoothen enabled. Patch "//trim(iStr)//": smooth_patch_id must be less than patch_id") - @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id == 0, & - "Smoothen enabled. Patch "//trim(iStr)//": smooth_patch_id must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%smooth_coeff <= 0._wp, & - "Smoothen enabled. Patch "//trim(iStr)//": smooth_coeff must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id >= patch_id, "Smoothen enabled. Patch "//trim(iStr)//": smooth_patch_id must be less than patch_id") + @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id == 0, "Smoothen enabled. Patch "//trim(iStr)//": smooth_patch_id must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%smooth_coeff <= 0._wp, "Smoothen enabled. Patch "//trim(iStr)//": smooth_coeff must be greater than zero") else - @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, & - "Smoothen disabled. Patch "//trim(iStr)//": smooth_patch_id must be equal to patch_id") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), & - "Smoothen disabled. Patch "//trim(iStr)//": smooth_coeff must not be set") + @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, "Smoothen disabled. Patch "//trim(iStr)//": smooth_patch_id must be equal to patch_id") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), "Smoothen disabled. Patch "//trim(iStr)//": smooth_coeff must not be set") end if - end subroutine s_check_supported_patch_smoothing - !> This subroutine verifies that inactive patches cannot be smoothed - !! @param patch_id Patch identifier + !! @param patch_id Patch identifier impure subroutine s_check_unsupported_patch_smoothing(patch_id) - ! Patch identifier integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(patch_icpp(patch_id)%smoothen, & - "Inactive patch "//trim(iStr)//": cannot have smoothen enabled") - @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, & - "Inactive patch "//trim(iStr)//": smooth_patch_id must be equal to patch_id") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), & - "Inactive patch "//trim(iStr)//": smooth_coeff must not be set") - + @:PROHIBIT(patch_icpp(patch_id)%smoothen, "Inactive patch "//trim(iStr)//": cannot have smoothen enabled") + @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, "Inactive patch "//trim(iStr)//": smooth_patch_id must be equal to patch_id") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), "Inactive patch "//trim(iStr)//": smooth_coeff must not be set") end subroutine s_check_unsupported_patch_smoothing - - !> This subroutine checks the primitive variables - !! @param patch_id Patch identifier + !> This subroutine checks the primitive variables + !! @param patch_id Patch identifier impure subroutine s_check_active_patch_primitive_variables(patch_id) - - integer, intent(in) :: patch_id - + integer, intent(in) :: patch_id logical, dimension(3) :: is_set_B call s_int_to_str(patch_id, iStr) - @:PROHIBIT(f_is_default(patch_icpp(patch_id)%vel(1)), & - "Patch "//trim(iStr)//": vel(1) must be set") - @:PROHIBIT(n == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(2))) .and. (.not. f_approx_equal(patch_icpp(patch_id)%vel(2) , 0._wp)) .and. (.not. mhd), & - "Patch "//trim(iStr)//": vel(2) must not be set when n = 0") - @:PROHIBIT(n > 0 .and. f_is_default(patch_icpp(patch_id)%vel(2)), & - "Patch "//trim(iStr)//": vel(2) must be set when n > 0") - @:PROHIBIT(p == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(3))) .and. (.not. f_approx_equal(patch_icpp(patch_id)%vel(3) , 0._wp)) .and. (.not. mhd), & - "Patch "//trim(iStr)//": vel(3) must not be set when p = 0") - @:PROHIBIT(p > 0 .and. f_is_default(patch_icpp(patch_id)%vel(3)), & - "Patch "//trim(iStr)//": vel(3) must be set when p > 0") - @:PROHIBIT(mhd .and. (f_is_default(patch_icpp(patch_id)%vel(2)) .or. f_is_default(patch_icpp(patch_id)%vel(3))), & - "Patch "//trim(iStr)//": All velocities (vel(1:3)) must be set when mhd = true") - @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%rho <= 0._wp, & - "Patch "//trim(iStr)//": rho must be greater than zero when model_eqns = 1") - @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%gamma <= 0._wp, & - "Patch "//trim(iStr)//": gamma must be greater than zero when model_eqns = 1") - @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%pi_inf < 0._wp, & - "Patch "//trim(iStr)//": pi_inf must be greater than or equal to zero when model_eqns = 1") - @:PROHIBIT(patch_icpp(patch_id)%geometry == 5 .and. patch_icpp(patch_id)%pi_inf > 0, & - "Patch "//trim(iStr)//": pi_inf must be less than or equal to zero when geometry = 5") - @:PROHIBIT(model_eqns == 2 .and. any(patch_icpp(patch_id)%alpha_rho(1:num_fluids) < 0._wp), & - "Patch "//trim(iStr)//": alpha_rho(1:num_fluids) must be greater than or equal to zero when model_eqns = 2") + @:PROHIBIT(f_is_default(patch_icpp(patch_id)%vel(1)), "Patch "//trim(iStr)//": vel(1) must be set") + @:PROHIBIT(n == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(2))) .and. (.not. f_approx_equal(patch_icpp(patch_id)%vel(2) , 0._wp)) .and. (.not. mhd), "Patch "//trim(iStr)//": vel(2) must not be set when n = 0") + @:PROHIBIT(n > 0 .and. f_is_default(patch_icpp(patch_id)%vel(2)), "Patch "//trim(iStr)//": vel(2) must be set when n > 0") + @:PROHIBIT(p == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(3))) .and. (.not. f_approx_equal(patch_icpp(patch_id)%vel(3) , 0._wp)) .and. (.not. mhd), "Patch "//trim(iStr)//": vel(3) must not be set when p = 0") + @:PROHIBIT(p > 0 .and. f_is_default(patch_icpp(patch_id)%vel(3)), "Patch "//trim(iStr)//": vel(3) must be set when p > 0") + @:PROHIBIT(mhd .and. (f_is_default(patch_icpp(patch_id)%vel(2)) .or. f_is_default(patch_icpp(patch_id)%vel(3))), "Patch "//trim(iStr)//": All velocities (vel(1:3)) must be set when mhd = true") + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%rho <= 0._wp, "Patch "//trim(iStr)//": rho must be greater than zero when model_eqns = 1") + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%gamma <= 0._wp, "Patch "//trim(iStr)//": gamma must be greater than zero when model_eqns = 1") + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%pi_inf < 0._wp, "Patch "//trim(iStr)//": pi_inf must be greater than or equal to zero when model_eqns = 1") + @:PROHIBIT(patch_icpp(patch_id)%geometry == 5 .and. patch_icpp(patch_id)%pi_inf > 0, "Patch "//trim(iStr)//": pi_inf must be less than or equal to zero when geometry = 5") + @:PROHIBIT(model_eqns == 2 .and. any(patch_icpp(patch_id)%alpha_rho(1:num_fluids) < 0._wp), "Patch "//trim(iStr)//": alpha_rho(1:num_fluids) must be greater than or equal to zero when model_eqns = 2") is_set_B(1) = .not. f_is_default(patch_icpp(patch_id)%Bx) is_set_B(2) = .not. f_is_default(patch_icpp(patch_id)%By) is_set_B(3) = .not. f_is_default(patch_icpp(patch_id)%Bz) - @:PROHIBIT(.not. mhd .and. any(is_set_B), & - "Bx, By, and Bz must not be set if MHD is not enabled") + @:PROHIBIT(.not. mhd .and. any(is_set_B), "Bx, By, and Bz must not be set if MHD is not enabled") @:PROHIBIT(mhd .and. n == 0 .and. is_set_B(1), "Bx must not be set in 1D MHD simulations") @:PROHIBIT(mhd .and. n > 0 .and. .not. is_set_B(1), "Bx must be set in 2D/3D MHD simulations") @:PROHIBIT(mhd .and. .not. (is_set_B(2) .and. is_set_B(3)), "By and Bz must be set in all MHD simulations") if (model_eqns == 2 .and. num_fluids < num_fluids_max) then - @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho(num_fluids + 1:)), & - "Patch "//trim(iStr)//": alpha_rho(i) must not be set for i > num_fluids") - @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha(num_fluids + 1:)), & - "Patch "//trim(iStr)//": alpha(i) must not be set for i > num_fluids") - @:PROHIBIT(f_is_default(patch_icpp(patch_id)%alpha(num_fluids)), & - "Patch "//trim(iStr)//": alpha(num_fluids) must be set") + @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho(num_fluids + 1:)), "Patch "//trim(iStr)//": alpha_rho(i) must not be set for i > num_fluids") + @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha(num_fluids + 1:)), "Patch "//trim(iStr)//": alpha(i) must not be set for i > num_fluids") + @:PROHIBIT(f_is_default(patch_icpp(patch_id)%alpha(num_fluids)), "Patch "//trim(iStr)//": alpha(num_fluids) must be set") end if if (chemistry) then !@:ASSERT(all(patch_icpp(patch_id)%Y(1:num_species) >= 0._wp), "Patch " // trim(iStr) // ".") !@:ASSERT(any(patch_icpp(patch_id)%Y(1:num_species) > verysmall), "Patch " // trim(iStr) // ".") end if - end subroutine s_check_active_patch_primitive_variables - - !> This subroutine verifies that the primitive variables - !! associated with the given inactive patch remain unaltered - !! by the user inputs. - !! @param patch_id Patch identifier + !> This subroutine verifies that the primitive variables associated with the given inactive patch remain unaltered by the user + !! inputs. + !! @param patch_id Patch identifier impure subroutine s_check_inactive_patch_primitive_variables(patch_id) - integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho), & - "Inactive patch "//trim(iStr)//": alpha_rho must not be set") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%rho), & - "Inactive patch "//trim(iStr)//": rho must not be set") - @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%vel), & - "Inactive patch "//trim(iStr)//": vel must not be set") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%pres), & - "Inactive patch "//trim(iStr)//": pres must not be set") - @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha), & - "Inactive patch "//trim(iStr)//": alpha must not be set") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%gamma), & - "Inactive patch "//trim(iStr)//": gamma must not be set") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%pi_inf), & - "Inactive patch "//trim(iStr)//": pi_inf must not be set") - + @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho), "Inactive patch "//trim(iStr)//": alpha_rho must not be set") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%rho), "Inactive patch "//trim(iStr)//": rho must not be set") + @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%vel), "Inactive patch "//trim(iStr)//": vel must not be set") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%pres), "Inactive patch "//trim(iStr)//": pres must not be set") + @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha), "Inactive patch "//trim(iStr)//": alpha must not be set") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%gamma), "Inactive patch "//trim(iStr)//": gamma must not be set") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%pi_inf), "Inactive patch "//trim(iStr)//": pi_inf must not be set") end subroutine s_check_inactive_patch_primitive_variables - !> @brief Verifies that the model file referenced by the given patch exists on disk. impure subroutine s_check_model_geometry(patch_id) - integer, intent(in) :: patch_id - - logical :: file_exists + logical :: file_exists inquire (file=patch_icpp(patch_id)%model_filepath, exist=file_exists) - @:PROHIBIT(.not. file_exists, "Model file "//trim(patch_icpp(patch_id)%model_filepath)// & - " requested by patch "//trim(iStr)//" does not exist") - + @:PROHIBIT(.not. file_exists, "Model file "//trim(patch_icpp(patch_id)%model_filepath)// " requested by patch "//trim(iStr)//" does not exist") end subroutine s_check_model_geometry - end module m_check_patches diff --git a/src/pre_process/m_checker.fpp b/src/pre_process/m_checker.fpp index 63ed19199b..bde17ff99b 100644 --- a/src/pre_process/m_checker.fpp +++ b/src/pre_process/m_checker.fpp @@ -6,7 +6,6 @@ !> @brief Checks pre-process input file parameters for compatibility and correctness module m_checker - use m_global_parameters !< Definitions of the global parameters use m_mpi_proxy !< Message passing interface (MPI) module proxy @@ -18,12 +17,9 @@ module m_checker implicit none private; public :: s_check_inputs - contains - !> Checks compatibility of parameters in the input file. - !! Used by the pre_process stage + !> Checks compatibility of parameters in the input file. Used by the pre_process stage impure subroutine s_check_inputs end subroutine s_check_inputs - end module m_checker diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index 5dbc84ade8..341225dfe9 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -4,7 +4,6 @@ !> @brief Writes grid and initial condition data to serial or parallel output files module m_data_output - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code @@ -35,33 +34,22 @@ module m_data_output implicit none - private; - public :: s_write_serial_data_files, & - s_write_parallel_data_files, & - s_write_data_files, & - s_initialize_data_output_module, & - s_finalize_data_output_module + private; + public :: s_write_serial_data_files, s_write_parallel_data_files, s_write_data_files, s_initialize_data_output_module, & + & s_finalize_data_output_module type(scalar_field), allocatable, dimension(:) :: q_cons_temp abstract interface - !> Interface for the conservative data + !> Interface for the conservative data !! @param q_cons_vf Conservative variables impure subroutine s_write_abstract_data_files(q_cons_vf, q_prim_vf, bc_type) - - import :: scalar_field, integer_field, sys_size, m, n, p, & - pres_field, num_dims + import :: scalar_field, integer_field, sys_size, m, n, p, pres_field, num_dims ! Conservative variables - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf, q_prim_vf - - type(integer_field), & - dimension(1:num_dims, -1:1), & - intent(in) :: bc_type - + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf + type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type end subroutine s_write_abstract_data_files end interface @@ -72,49 +60,36 @@ module m_data_output !! Restart data folder procedure(s_write_abstract_data_files), pointer :: s_write_data_files => null() - contains - !> Writes grid and initial condition data files to the "0" - !! time-step directory in the local processor rank folder + !> Writes grid and initial condition data files to the "0" time-step directory in the local processor rank folder !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables !! @param bc_type Boundary condition types impure subroutine s_write_serial_data_files(q_cons_vf, q_prim_vf, bc_type) - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf, q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf ! BC types - type(integer_field), & - dimension(1:num_dims, -1:1), & - intent(in) :: bc_type - - logical :: file_exist !< checks if file exists - - character(LEN=15) :: FMT - character(LEN=3) :: status - - character(LEN= & - int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< Used to store + type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type + logical :: file_exist !< checks if file exists + character(LEN=15) :: FMT + character(LEN=3) :: status + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< Used to store !! the number, in character form, of the currently !! manipulated conservative variable data file character(LEN=len_trim(t_step_dir) + name_len) :: file_loc !< !! Generic string used to store the address of a particular file - integer :: i, j, k, l, r, c !< Generic loop iterator - integer :: t_step - + integer :: i, j, k, l, r, c !< Generic loop iterator + integer :: t_step real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration - real(wp) :: nbub !< Temporary bubble number density - real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params - real(wp) :: rho !< Temporary density - real(wp) :: pres, T !< Temporary pressure - - real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions - - real(wp) :: pres_mag + real(wp) :: nbub !< Temporary bubble number density + real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params + real(wp) :: rho !< Temporary density + real(wp) :: pres, T !< Temporary pressure + real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions + real(wp) :: pres_mag pres_mag = 0._wp @@ -139,25 +114,23 @@ contains end if ! x-coordinate direction - file_loc = trim(t_step_dir)//'/x_cb.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', STATUS=status) + file_loc = trim(t_step_dir) // '/x_cb.dat' + open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) write (1) x_cb(-1:m) close (1) ! y- and z-coordinate directions if (n > 0) then ! y-coordinate direction - file_loc = trim(t_step_dir)//'/y_cb.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS=status) + file_loc = trim(t_step_dir) // '/y_cb.dat' + open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) write (1) y_cb(-1:n) close (1) ! z-coordinate direction if (p > 0) then - file_loc = trim(t_step_dir)//'/z_cb.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS=status) + file_loc = trim(t_step_dir) // '/z_cb.dat' + open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) write (1) z_cb(-1:p) close (1) end if @@ -166,24 +139,20 @@ contains ! Outputting Conservative Variables do i = 1, sys_size write (file_num, '(I0)') i - file_loc = trim(t_step_dir)//'/q_cons_vf'//trim(file_num) & - //'.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS=status) + file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' + open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) write (1) q_cons_vf(i)%sf(0:m, 0:n, 0:p) close (1) end do - !Outputting pb and mv for non-polytropic qbmm + ! Outputting pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode write (file_num, '(I0)') r + (i - 1)*nnode + sys_size - file_loc = trim(t_step_dir)//'/pb'//trim(file_num) & - //'.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS=status) - write (1) pb%sf(:, :, :, r, i) + file_loc = trim(t_step_dir) // '/pb' // trim(file_num) // '.dat' + open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) + write (1) pb%sf(:,:,:, r, i) close (1) end do end do @@ -191,11 +160,9 @@ contains do i = 1, nb do r = 1, nnode write (file_num, '(I0)') r + (i - 1)*nnode + sys_size - file_loc = trim(t_step_dir)//'/mv'//trim(file_num) & - //'.dat' - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS=status) - write (1) mv%sf(:, :, :, r, i) + file_loc = trim(t_step_dir) // '/mv' // trim(file_num) // '.dat' + open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) + write (1) mv%sf(:,:,:, r, i) close (1) end do end do @@ -212,8 +179,8 @@ contains FMT = "(2F40.14)" end if - write (t_step_dir, '(A,I0,A,I0)') trim(case_dir)//'/D' - file_loc = trim(t_step_dir)//'/.' + write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/D' + file_loc = trim(t_step_dir) // '/.' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -221,15 +188,14 @@ contains if (cfl_dt) t_step = n_start - !1D + ! 1D if (n == 0 .and. p == 0) then if (model_eqns == 2) then do i = 1, sys_size - write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/prim.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/prim.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m - if (chemistry) then do c = 1, num_species rhoYks(c) = q_cons_vf(chemxb + c - 1)%sf(j, 0, 0) @@ -242,27 +208,22 @@ contains if ((i >= chemxb) .and. (i <= chemxe)) then write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0)/rho - else if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) & - .or. & - ((i >= adv_idx%beg) .and. (i <= adv_idx%end)) & - .or. & - ((i >= chemxb) .and. (i <= chemxe)) & - ) then + else if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) .or. ((i >= adv_idx%beg) .and. (i <= adv_idx%end) & + & ) .or. ((i >= chemxb) .and. (i <= chemxe))) then write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0) - else if (i == mom_idx%beg) then !u + else if (i == mom_idx%beg) then ! u write (2, FMT) x_cb(j), q_cons_vf(mom_idx%beg)%sf(j, 0, 0)/rho - else if (i == stress_idx%beg) then !tau_e + else if (i == stress_idx%beg) then ! tau_e write (2, FMT) x_cb(j), q_cons_vf(stress_idx%beg)%sf(j, 0, 0)/rho - else if (i == E_idx) then !p + else if (i == E_idx) then ! p if (mhd) then - pres_mag = 0.5_wp*(Bx0**2 + q_cons_vf(B_idx%beg)%sf(j, 0, 0)**2 + q_cons_vf(B_idx%beg + 1)%sf(j, 0, 0)**2) + pres_mag = 0.5_wp*(Bx0**2 + q_cons_vf(B_idx%beg)%sf(j, 0, 0)**2 + q_cons_vf(B_idx%beg + 1)%sf(j, & + & 0, 0)**2) end if - call s_compute_pressure( & - q_cons_vf(E_idx)%sf(j, 0, 0), & - q_cons_vf(alf_idx)%sf(j, 0, 0), & - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, 0, 0)**2._wp)/rho, & - pi_inf, gamma, rho, qv, rhoYks, pres, T, pres_mag=pres_mag) + call s_compute_pressure(q_cons_vf(E_idx)%sf(j, 0, 0), q_cons_vf(alf_idx)%sf(j, 0, 0), & + & 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, 0, 0)**2._wp)/rho, pi_inf, gamma, rho, & + & qv, rhoYks, pres, T, pres_mag=pres_mag) write (2, FMT) x_cb(j), pres else if (mhd) then if (i == mom_idx%beg + 1) then ! v @@ -275,7 +236,6 @@ contains write (2, FMT) x_cb(j), q_cons_vf(B_idx%beg + 1)%sf(j, 0, 0)/rho end if else if ((i >= bub_idx%beg) .and. (i <= bub_idx%end) .and. bubbles_euler) then - if (qbmm) then nbub = q_cons_vf(bubxb)%sf(j, 0, 0) else @@ -301,7 +261,7 @@ contains end if do i = 1, sys_size - write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/cons.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -313,7 +273,8 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -324,7 +285,8 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -345,7 +307,7 @@ contains ! 2D if ((n > 0) .and. (p == 0)) then do i = 1, sys_size - write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/cons.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m do k = 0, n @@ -359,7 +321,8 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -372,7 +335,8 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -395,7 +359,7 @@ contains ! 3D if (p > 0) then do i = 1, sys_size - write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/cons.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m do k = 0, n @@ -412,7 +376,8 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -427,7 +392,8 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -442,40 +408,30 @@ contains end do end if end if - end subroutine s_write_serial_data_files - - !> Writes grid and initial condition data files in parallel to the "0" - !! time-step directory in the local processor rank folder + !> Writes grid and initial condition data files in parallel to the "0" time-step directory in the local processor rank folder !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables !! @param bc_type Boundary condition types impure subroutine s_write_parallel_data_files(q_cons_vf, q_prim_vf, bc_type) - ! Conservative variables - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf, q_prim_vf - - type(integer_field), & - dimension(1:num_dims, -1:1), & - intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf + type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type #ifdef MFC_MPI - integer :: ifile, ierr, data_size - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer(KIND=MPI_OFFSET_KIND) :: m_MOK, n_MOK, p_MOK - integer(KIND=MPI_OFFSET_KIND) :: WP_MOK, var_MOK, str_MOK - integer(KIND=MPI_OFFSET_KIND) :: NVARS_MOK - integer(KIND=MPI_OFFSET_KIND) :: MOK - + integer :: ifile, ierr, data_size + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer(KIND=MPI_OFFSET_KIND) :: m_MOK, n_MOK, p_MOK + integer(KIND=MPI_OFFSET_KIND) :: WP_MOK, var_MOK, str_MOK + integer(KIND=MPI_OFFSET_KIND) :: NVARS_MOK + integer(KIND=MPI_OFFSET_KIND) :: MOK character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist, dir_check + logical :: file_exist, dir_check ! Generic loop iterators - integer :: i, j, k, l + integer :: i, j, k, l real(wp) :: loc_violations, glb_violations ! Downsample variables @@ -491,17 +447,17 @@ contains end if call s_mpi_allreduce_sum(loc_violations, glb_violations) if (proc_rank == 0 .and. nint(glb_violations) > 0) then - print *, "WARNING: Attempting to downsample data but there are"// & - "processors with local problem sizes that are not divisible by 3." + print *, & + & "WARNING: Attempting to downsample data but there are" & + & // "processors with local problem sizes that are not divisible by 3." end if call s_populate_variables_buffers(bc_type, q_cons_vf) - call s_downsample_data(q_cons_vf, q_cons_temp, & - m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) + call s_downsample_data(q_cons_vf, q_cons_temp, m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) end if if (file_per_process) then if (proc_rank == 0) then - file_loc = trim(case_dir)//'/restart_data/lustre_0' + file_loc = trim(case_dir) // '/restart_data/lustre_0' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then call s_create_directory(trim(file_loc)) @@ -524,14 +480,13 @@ contains else write (file_loc, '(I0,A,i7.7,A)') t_step_start, '_', proc_rank, '.dat' end if - file_loc = trim(restart_dir)//'/lustre_0'//trim(mpiiofs)//trim(file_loc) + file_loc = trim(restart_dir) // '/lustre_0' // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist .and. proc_rank == 0) then call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) end if if (file_exist) call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) if (down_sample) then ! Size of local arrays @@ -558,19 +513,17 @@ contains ! Write the data for each variable if (bubbles_euler) then - do i = 1, sys_size! adv_idx%end + do i = 1, sys_size ! adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - !Additional variables pb and mv for non-polytropic qbmm + ! Additional variables pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if else @@ -578,21 +531,18 @@ contains do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_WRITE_ALL(ifile, q_cons_temp(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, q_cons_temp(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do else do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if end if call MPI_FILE_CLOSE(ifile, ierr) - else call s_initialize_mpi_data(q_cons_vf) @@ -602,13 +552,12 @@ contains else write (file_loc, '(I0,A)') t_step_start, '.dat' end if - file_loc = trim(restart_dir)//trim(mpiiofs)//trim(file_loc) + file_loc = trim(restart_dir) // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist .and. proc_rank == 0) then call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) end if - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) @@ -624,18 +573,16 @@ contains ! Write the data for each variable if (bubbles_euler) then - do i = 1, sys_size! adv_idx%end + do i = 1, sys_size ! adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - !Additional variables pb and mv for non-polytropic qbmm + ! Additional variables pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) @@ -643,26 +590,21 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if else - do i = 1, sys_size !TODO: check if this is right + do i = 1, sys_size ! TODO: check if this is right ! do i = 1, adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - end if call MPI_FILE_CLOSE(ifile, ierr) @@ -676,27 +618,23 @@ contains call s_write_parallel_boundary_condition_files(q_prim_vf, bc_type) end if end if - end subroutine s_write_parallel_data_files - - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_data_output_module ! Generic string used to store the address of a particular file character(LEN=len_trim(case_dir) + 2*name_len) :: file_loc - character(len=15) :: temp - character(LEN=1), dimension(3), parameter :: coord = (/'x', 'y', 'z'/) + character(len=15) :: temp + character(LEN=1), dimension(3), parameter :: coord = (/'x', 'y', 'z'/) ! Generic logical used to check the existence of directories logical :: dir_check integer :: i - integer :: m_ds, n_ds, p_ds !< down sample dimensions if (parallel_io .neqv. .true.) then ! Setting the address of the time-step directory write (t_step_dir, '(A,I0,A)') '/p_all/p', proc_rank, '/0' - t_step_dir = trim(case_dir)//trim(t_step_dir) + t_step_dir = trim(case_dir) // trim(t_step_dir) ! Checking the existence of the time-step directory, removing it, if ! it exists, and creating a new copy. Note that if preexisting grid @@ -704,25 +642,22 @@ contains ! location, then the above described steps are not executed here but ! rather in the module m_start_up.f90. if (old_grid .neqv. .true.) then - - file_loc = trim(t_step_dir)//'/' + file_loc = trim(t_step_dir) // '/' call my_inquire(file_loc, dir_check) if (dir_check) call s_delete_directory(trim(t_step_dir)) call s_create_directory(trim(t_step_dir)) - end if s_write_data_files => s_write_serial_data_files else write (restart_dir, '(A)') '/restart_data' - restart_dir = trim(case_dir)//trim(restart_dir) + restart_dir = trim(case_dir) // trim(restart_dir) if ((old_grid .neqv. .true.) .and. (proc_rank == 0)) then - - file_loc = trim(restart_dir)//'/' + file_loc = trim(restart_dir) // '/' call my_inquire(file_loc, dir_check) if (dir_check) call s_delete_directory(trim(restart_dir)) @@ -732,7 +667,6 @@ contains call s_mpi_barrier() s_write_data_files => s_write_parallel_data_files - end if open (1, FILE='indices.dat', STATUS='unknown') @@ -744,21 +678,23 @@ contains write (1, '(A)') " " do i = contxb, contxe write (temp, '(I0)') i - contxb + 1 - write (1, '(I3,A20,A20)') i, "\alpha_{"//trim(temp)//"} \rho_{"//trim(temp)//"}", "\alpha_{"//trim(temp)//"} \rho" + write (1, '(I3,A20,A20)') i, "\alpha_{" // trim(temp) // "} \rho_{" // trim(temp) // "}", & + & "\alpha_{" // trim(temp) // "} \rho" end do do i = momxb, momxe - write (1, '(I3,A20,A20)') i, "\rho u_"//coord(i - momxb + 1), "u_"//coord(i - momxb + 1) + write (1, '(I3,A20,A20)') i, "\rho u_" // coord(i - momxb + 1), "u_" // coord(i - momxb + 1) end do do i = E_idx, E_idx write (1, '(I3,A20,A20)') i, "\rho U", "p" end do do i = advxb, advxe write (temp, '(I0)') i - contxb + 1 - write (1, '(I3,A20,A20)') i, "\alpha_{"//trim(temp)//"}", "\alpha_{"//trim(temp)//"}" + write (1, '(I3,A20,A20)') i, "\alpha_{" // trim(temp) // "}", "\alpha_{" // trim(temp) // "}" end do if (chemistry) then do i = 1, num_species - write (1, '(I3,A20,A20)') chemxb + i - 1, "Y_{"//trim(species_names(i))//"} \rho", "Y_{"//trim(species_names(i))//"}" + write (1, '(I3,A20,A20)') chemxb + i - 1, "Y_{" // trim(species_names(i)) // "} \rho", & + & "Y_{" // trim(species_names(i)) // "}" end do end if @@ -784,12 +720,9 @@ contains allocate (q_cons_temp(i)%sf(-1:m_ds + 1, -1:n_ds + 1, -1:p_ds + 1)) end do end if - end subroutine s_initialize_data_output_module - !> Resets s_write_data_files pointer impure subroutine s_finalize_data_output_module - integer :: i s_write_data_files => null() @@ -800,7 +733,5 @@ contains end do deallocate (q_cons_temp) end if - end subroutine s_finalize_data_output_module - end module m_data_output diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 886294f515..4877655685 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -6,28 +6,26 @@ !> @brief Defines global parameters for the computational domain, simulation algorithm, and initial conditions module m_global_parameters - #ifdef MFC_MPI - use mpi ! Message passing interface (MPI) module + use mpi ! Message passing interface (MPI) module #endif - use m_derived_types ! Definitions of the derived types + use m_derived_types ! Definitions of the derived types - use m_helper_basic ! Functions to compare floating point numbers + use m_helper_basic ! Functions to compare floating point numbers use m_thermochem, only: num_species implicit none ! Logistics - integer :: num_procs !< Number of processors + integer :: num_procs !< Number of processors character(LEN=path_len) :: case_dir !< Case folder location - logical :: old_grid !< Use existing grid data - logical :: old_ic, non_axis_sym !< Use existing IC data - integer :: t_step_old, t_step_start !< Existing IC/grid folder - - logical :: cfl_adap_dt, cfl_const_dt, cfl_dt - integer :: n_start, n_start_old + logical :: old_grid !< Use existing grid data + logical :: old_ic, non_axis_sym !< Use existing IC data + integer :: t_step_old, t_step_start !< Existing IC/grid folder + logical :: cfl_adap_dt, cfl_const_dt, cfl_dt + integer :: n_start, n_start_old ! Computational Domain Parameters @@ -39,18 +37,13 @@ module m_global_parameters integer :: p !> @name Max and min number of cells in a direction of each combination of x-,y-, and z- - type(cell_num_bounds) :: cells_bounds - - integer(kind=8) :: nGlobal !< Global number of cells in the domain - - integer :: m_glb, n_glb, p_glb !< Global number of cells in each direction - - integer :: num_dims !< Number of spatial dimensions - integer :: num_vels !< Number of velocity components (different from num_dims for mhd) - - logical :: cyl_coord - integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) - + type(cell_num_bounds) :: cells_bounds + integer(kind=8) :: nGlobal !< Global number of cells in the domain + integer :: m_glb, n_glb, p_glb !< Global number of cells in each direction + integer :: num_dims !< Number of spatial dimensions + integer :: num_vels !< Number of velocity components (different from num_dims for mhd) + logical :: cyl_coord + integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) real(wp), allocatable, dimension(:) :: x_cc, y_cc, z_cc !< !! Locations of cell-centers (cc) in x-, y- and z-directions, respectively @@ -71,56 +64,56 @@ module m_global_parameters ! is stretched while the remaining parameters are indicative of the location ! on the grid at which the stretching begins. real(wp) :: a_x, a_y, a_z - integer :: loops_x, loops_y, loops_z + integer :: loops_x, loops_y, loops_z real(wp) :: x_a, y_a, z_a real(wp) :: x_b, y_b, z_b ! Simulation Algorithm Parameters - integer :: model_eqns !< Multicomponent flow model - logical :: relax !< activate phase change - integer :: relax_model !< Relax Model - real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model - real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model - integer :: num_fluids !< Number of different fluids present in the flow - logical :: mpp_lim !< Alpha limiter - integer :: sys_size !< Number of unknowns in the system of equations - integer :: recon_type !< Reconstruction Type - integer :: weno_polyn !< Degree of the WENO polynomials (polyn) - integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn) - integer :: weno_order !< Order of accuracy for the WENO reconstruction - integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction - logical :: hypoelasticity !< activate hypoelasticity - logical :: hyperelasticity !< activate hyperelasticity - logical :: elasticity !< elasticity modeling, true for hyper or hypo - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity for RMHD - integer :: b_size !< Number of components in the b tensor - integer :: tensor_size !< Number of components in the nonsymmetric tensor - logical :: pre_stress !< activate pre_stressed domain - logical :: cont_damage !< continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD - logical :: igr !< Use information geometric regularization - integer :: igr_order !< IGR reconstruction order + integer :: model_eqns !< Multicomponent flow model + logical :: relax !< activate phase change + integer :: relax_model !< Relax Model + real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model + real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model + integer :: num_fluids !< Number of different fluids present in the flow + logical :: mpp_lim !< Alpha limiter + integer :: sys_size !< Number of unknowns in the system of equations + integer :: recon_type !< Reconstruction Type + integer :: weno_polyn !< Degree of the WENO polynomials (polyn) + integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn) + integer :: weno_order !< Order of accuracy for the WENO reconstruction + integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction + logical :: hypoelasticity !< activate hypoelasticity + logical :: hyperelasticity !< activate hyperelasticity + logical :: elasticity !< elasticity modeling, true for hyper or hypo + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity for RMHD + integer :: b_size !< Number of components in the b tensor + integer :: tensor_size !< Number of components in the nonsymmetric tensor + logical :: pre_stress !< activate pre_stressed domain + logical :: cont_damage !< continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD + logical :: igr !< Use information geometric regularization + integer :: igr_order !< IGR reconstruction order logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling ! Annotations of the structure, i.e. the organization, of the state vectors type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of total energy equation - integer :: alf_idx !< Index of void fraction - integer :: n_idx !< Index of number density + integer :: E_idx !< Index of total energy equation + integer :: alf_idx !< Index of void fraction + integer :: n_idx !< Index of number density type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. type(int_bounds_info) :: stress_idx !< Indexes of elastic shear stress eqns. type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: c_idx !< Index of the color function + integer :: c_idx !< Index of the color function type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). ! Stands for "InDices With BUFFer". @@ -130,11 +123,10 @@ module m_global_parameters ! this includes the buffer region. idwbuff and idwint are the same otherwise. ! Stands for "InDices With BUFFer". type(int_bounds_info) :: idwbuff(1:3) - type(int_bounds_info) :: bc_x, bc_y, bc_z !< !! Boundary conditions in the x-, y- and z-coordinate directions - integer :: shear_num !! Number of shear stress components + integer :: shear_num !! Number of shear stress components integer, dimension(3) :: shear_indices !< !! Indices of the stress components that represent shear stress integer :: shear_BC_flip_num !< @@ -143,38 +135,33 @@ module m_global_parameters !! Indices of shear stress components to reflect for boundary conditions. !! Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, [indices]) - logical :: parallel_io !< Format of the data files - logical :: file_per_process !< type of data output - integer :: precision !< Precision of output files - logical :: down_sample !< Down-sample the output data - - logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile + logical :: parallel_io !< Format of the data files + logical :: file_per_process !< type of data output + integer :: precision !< Precision of output files + logical :: down_sample !< Down-sample the output data + logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile - logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow - integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag + logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow + integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag real(wp) :: mixlayer_perturb_k0 !< Peak wavenumber of prescribed energy spectra with mixlayer_perturb flag !! Default value (k0 = 0.4446) is most unstable mode obtained from linear stability analysis !! See Michalke (1964, JFM) for details - logical :: simplex_perturb + logical :: simplex_perturb type(simplex_noise_params) :: simplex_params - - real(wp) :: pi_fac !< Factor for artificial pi_inf - - logical :: viscous - logical :: bubbles_lagrange + real(wp) :: pi_fac !< Factor for artificial pi_inf + logical :: viscous + logical :: bubbles_lagrange ! Perturb density of surrounding air so as to break symmetry of grid - logical :: perturb_flow - integer :: perturb_flow_fluid !< Fluid to be perturbed with perturb_flow flag - real(wp) :: perturb_flow_mag !< Magnitude of perturbation with perturb_flow flag - logical :: perturb_sph - integer :: perturb_sph_fluid !< Fluid to be perturbed with perturb_sph flag + logical :: perturb_flow + integer :: perturb_flow_fluid !< Fluid to be perturbed with perturb_flow flag + real(wp) :: perturb_flow_mag !< Magnitude of perturbation with perturb_flow flag + logical :: perturb_sph + integer :: perturb_sph_fluid !< Fluid to be perturbed with perturb_sph flag real(wp), dimension(num_fluids_max) :: fluid_rho - - logical :: elliptic_smoothing - integer :: elliptic_smoothing_iters - - integer, allocatable, dimension(:) :: proc_coords !< + logical :: elliptic_smoothing + integer :: elliptic_smoothing_iters + integer, allocatable, dimension(:) :: proc_coords !< !! Processor coordinates in MPI_CART_COMM integer, allocatable, dimension(:) :: start_idx !< @@ -183,24 +170,21 @@ module m_global_parameters #ifdef MFC_MPI type(mpi_io_var), public :: MPI_IO_DATA - - character(LEN=name_len) :: mpiiofs - integer :: mpi_info_int !< + character(LEN=name_len) :: mpiiofs + integer :: mpi_info_int !< !! MPI info for parallel IO with Lustre file systems - #endif ! Initial Condition Parameters - integer :: num_patches !< Number of patches composing initial condition - + integer :: num_patches !< Number of patches composing initial condition type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp !< !! Database of the initial condition patch parameters (icpp) for each of the !! patches employed in the configuration of the initial condition. Note that !! the maximum allowable number of patches, num_patches_max, may be changed !! in the module m_derived_types.f90. - integer :: num_bc_patches !< Number of boundary condition patches - logical :: bc_io !< whether or not to save BC data + integer :: num_bc_patches !< Number of boundary condition patches + logical :: bc_io !< whether or not to save BC data type(bc_patch_parameters), dimension(num_bc_patches_max) :: patch_bc !! Database of the boundary condition patch parameters for each of the patches !! employed in the configuration of the boundary conditions @@ -213,31 +197,27 @@ module m_global_parameters ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp - - real(wp) :: rhoref, pref !< Reference parameters for Tait EOS - - type(chemistry_parameters) :: chem_params + real(wp) :: rhoref, pref !< Reference parameters for Tait EOS + type(chemistry_parameters) :: chem_params !> @name Bubble modeling !> @{ - integer :: nb - real(wp) :: Ca, Web, Re_inv, Eu + integer :: nb + real(wp) :: Ca, Web, Re_inv, Eu real(wp), dimension(:), allocatable :: weight, R0 - logical :: bubbles_euler - logical :: qbmm !< Quadrature moment method - integer :: nmom !< Number of carried moments - real(wp) :: sigR, sigV, rhoRV !< standard deviations in R/V - logical :: adv_n !< Solve the number density equation and compute alpha from number density + logical :: bubbles_euler + logical :: qbmm !< Quadrature moment method + integer :: nmom !< Number of carried moments + real(wp) :: sigR, sigV, rhoRV !< standard deviations in R/V + logical :: adv_n !< Solve the number density equation and compute alpha from number density !> @} !> @name Immersed Boundaries !> @{ - logical :: ib !< Turn immersed boundaries on - integer :: num_ibs !< Number of immersed boundaries - integer :: Np - + logical :: ib !< Turn immersed boundaries on + integer :: num_ibs !< Number of immersed boundaries + integer :: Np type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib - - type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l + type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l !! Database of the immersed boundary patch parameters for each of the !! patches employed in the configuration of the initial condition. Note that !! the maximum allowable number of patches, num_patches_max, may be changed @@ -247,28 +227,23 @@ module m_global_parameters !> @name Non-polytropic bubble gas compression !> @{ - logical :: polytropic - logical :: polydisperse - real(wp) :: poly_sigma - integer :: dist_type !1 = binormal, 2 = lognormal-normal - - integer :: thermal !1 = adiabatic, 2 = isotherm, 3 = transfer - - real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl - real(wp) :: gam_m - + logical :: polytropic + logical :: polydisperse + real(wp) :: poly_sigma + integer :: dist_type ! 1 = binormal, 2 = lognormal-normal + integer :: thermal ! 1 = adiabatic, 2 = isotherm, 3 = transfer + real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl + real(wp) :: gam_m real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g real(wp), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN - - real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, & - gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g + real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g !> @} !> @name Surface Tension Modeling !> @{ real(wp) :: sigma - logical :: surface_tension + logical :: surface_tension !> @} !> @name Index variables used for m_variables_conversion @@ -283,28 +258,22 @@ module m_global_parameters integer :: chemxb, chemxe !> @} - integer, allocatable, dimension(:, :, :) :: logic_grid - - type(pres_field) :: pb - type(pres_field) :: mv - - real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) - - integer :: buff_size !< + integer, allocatable, dimension(:,:,:) :: logic_grid + type(pres_field) :: pb + type(pres_field) :: mv + real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) + integer :: buff_size !< !! The number of cells that are necessary to be able to store enough boundary !! conditions data to march the solution in the physical computational domain !! to the next time-step. logical :: fft_wrt logical :: dummy !< AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional is false - contains - !> Assigns default values to user inputs prior to reading - !! them in. This allows for an easier consistency check of - !! these parameters once they are read from the input file. + !> Assigns default values to user inputs prior to reading them in. This allows for an easier consistency check of these + !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs - integer :: i !< Generic loop operator ! Logistics @@ -413,11 +382,11 @@ contains simplex_params%perturb_vel(:) = .false. simplex_params%perturb_vel_freq(:) = dflt_real simplex_params%perturb_vel_scale(:) = dflt_real - simplex_params%perturb_vel_offset(:, :) = dflt_real + simplex_params%perturb_vel_offset(:,:) = dflt_real simplex_params%perturb_dens(:) = .false. simplex_params%perturb_dens_freq(:) = dflt_real simplex_params%perturb_dens_scale(:) = dflt_real - simplex_params%perturb_dens_offset(:, :) = dflt_real + simplex_params%perturb_dens_offset(:,:) = dflt_real ! Initial condition parameters num_patches = dflt_int @@ -473,9 +442,9 @@ contains patch_icpp(i)%modal_clip_r_to_min = .false. patch_icpp(i)%modal_r_min = 1.e-12_wp patch_icpp(i)%modal_use_exp_form = .false. - patch_icpp(i)%sph_har_coeff(:, :) = 0._wp + patch_icpp(i)%sph_har_coeff(:,:) = 0._wp - !should get all of r0's and v0's + ! should get all of r0's and v0's patch_icpp(i)%r0 = dflt_real patch_icpp(i)%v0 = dflt_real @@ -617,24 +586,20 @@ contains bub_pp%gam_g = dflt_real; gam_g = dflt_real bub_pp%M_v = dflt_real; M_v = dflt_real bub_pp%M_g = dflt_real; M_g = dflt_real - bub_pp%k_v = dflt_real; - bub_pp%k_g = dflt_real; + bub_pp%k_v = dflt_real; + bub_pp%k_g = dflt_real; bub_pp%cp_v = dflt_real; cp_v = dflt_real bub_pp%cp_g = dflt_real; cp_g = dflt_real bub_pp%R_v = dflt_real; R_v = dflt_real bub_pp%R_g = dflt_real; R_g = dflt_real - end subroutine s_assign_default_values_to_user_inputs - - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_global_parameters_module - integer :: i, j, fac if (recon_type == WENO_TYPE) then weno_polyn = (weno_order - 1)/2 - elseif (recon_type == MUSCL_TYPE) then + else if (recon_type == MUSCL_TYPE) then muscl_polyn = muscl_order end if @@ -644,7 +609,6 @@ contains ! Gamma/Pi_inf Model if (model_eqns == 1) then - ! Setting number of fluids num_fluids = 1 @@ -664,7 +628,6 @@ contains ! Volume Fraction Model (5-equation model) else if (model_eqns == 2) then - ! Annotating structure of the state and flux vectors belonging ! to the system of equations defined by the selected number of ! spatial dimensions and the volume fraction model @@ -769,7 +732,6 @@ contains ! Volume Fraction Model (6-equation model) else if (model_eqns == 3) then - ! Annotating structure of the state and flux vectors belonging ! to the system of equations defined by the selected number of ! spatial dimensions and the volume fraction model @@ -783,7 +745,6 @@ contains internalEnergies_idx%beg = adv_idx%end + 1 internalEnergies_idx%end = adv_idx%end + num_fluids sys_size = internalEnergies_idx%end - else if (model_eqns == 4) then ! 4 equation model with subgrid bubbles_euler cont_idx%beg = 1 ! one continuity equation @@ -792,9 +753,9 @@ contains mom_idx%end = cont_idx%end + num_vels E_idx = mom_idx%end + 1 ! one energy equation adv_idx%beg = E_idx + 1 - adv_idx%end = adv_idx%beg !one volume advection equation + adv_idx%end = adv_idx%beg ! one volume advection equation alf_idx = adv_idx%end - sys_size = alf_idx !adv_idx%end + sys_size = alf_idx ! adv_idx%end if (bubbles_euler) then bub_idx%beg = sys_size + 1 @@ -835,12 +796,10 @@ contains rhoref = 1._wp pref = 1._wp end if - end if end if if (model_eqns == 2 .or. model_eqns == 3) then - if (hypoelasticity .or. hyperelasticity) then elasticity = .true. stress_idx%beg = sys_size + 1 @@ -895,7 +854,6 @@ contains psi_idx = sys_size + 1 sys_size = psi_idx end if - end if if (chemistry) then @@ -921,11 +879,8 @@ contains chemxb = species_idx%beg chemxe = species_idx%end - call s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, & - igr_order, buff_size, & - idwint, idwbuff, viscous, & - bubbles_lagrange, m, n, p, & - num_dims, igr, ib) + call s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & + & bubbles_lagrange, m, n, p, num_dims, igr, ib) #ifdef MFC_MPI @@ -963,7 +918,7 @@ contains if (cyl_coord .neqv. .true.) then ! Cartesian grid grid_geometry = 1 - elseif (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid + else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid grid_geometry = 2 else ! Fully 3D cylindrical grid grid_geometry = 3 @@ -972,12 +927,9 @@ contains if (.not. igr) then allocate (logic_grid(0:m, 0:n, 0:p)) end if - end subroutine s_initialize_global_parameters_module - !> @brief Configures MPI parallel I/O settings and allocates processor coordinate arrays. impure subroutine s_initialize_parallel_io - #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors #endif @@ -1008,14 +960,10 @@ contains ! mpi_info_int = MPI_INFO_NULL allocate (start_idx(1:num_dims)) - #endif - end subroutine s_initialize_parallel_io - !> @brief Deallocates all global grid, index, and equation-of-state parameter arrays. impure subroutine s_finalize_global_parameters_module - integer :: i ! Deallocating grid variables for the x-direction @@ -1041,9 +989,6 @@ contains deallocate (MPI_IO_DATA%var) deallocate (MPI_IO_DATA%view) end if - #endif - end subroutine s_finalize_global_parameters_module - end module m_global_parameters diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index 6ea71bd592..b0ae678d22 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -4,50 +4,39 @@ !> @brief Generates uniform or stretched rectilinear grids with hyperbolic-tangent spacing module m_grid + use m_derived_types ! Definitions of the derived types - use m_derived_types ! Definitions of the derived types + use m_global_parameters ! Global parameters for the code - use m_global_parameters ! Global parameters for the code - - use m_mpi_proxy ! Message passing interface (MPI) module proxy + use m_mpi_proxy ! Message passing interface (MPI) module proxy use m_helper_basic !< Functions to compare floating point numbers #ifdef MFC_MPI - use mpi ! Message passing interface (MPI) module + use mpi ! Message passing interface (MPI) module #endif implicit none - private; - public :: s_initialize_grid_module, & - s_generate_grid, & - s_generate_serial_grid, & - s_generate_parallel_grid, & - s_finalize_grid_module + private; + public :: s_initialize_grid_module, s_generate_grid, s_generate_serial_grid, s_generate_parallel_grid, s_finalize_grid_module abstract interface !> @brief Abstract interface for generating a rectilinear computational grid. impure subroutine s_generate_abstract_grid - end subroutine s_generate_abstract_grid - end interface procedure(s_generate_abstract_grid), pointer :: s_generate_grid => null() - contains - !> The following subroutine generates either a uniform or - !! non-uniform rectilinear grid in serial, defined by the parameters - !! inputted by the user. The grid information is stored in - !! the grid variables containing coordinates of the cell- - !! centers and cell-boundaries. + !> The following subroutine generates either a uniform or non-uniform rectilinear grid in serial, defined by the parameters + !! inputted by the user. The grid information is stored in the grid variables containing coordinates of the cell- centers and + !! cell-boundaries. impure subroutine s_generate_serial_grid - ! Generic loop iterator - integer :: i, j !< generic loop operators + integer :: i, j !< generic loop operators real(wp) :: length !< domain lengths ! Grid Generation in the x-direction @@ -61,7 +50,6 @@ impure subroutine s_generate_serial_grid x_cb(m) = x_domain%end if (stretch_x) then - length = abs(x_cb(m) - x_cb(-1)) x_cb = x_cb/length x_a = x_a/length @@ -69,10 +57,8 @@ impure subroutine s_generate_serial_grid do j = 1, loops_x do i = -1, m - x_cb(i) = x_cb(i)/a_x* & - (a_x + log(cosh(a_x*(x_cb(i) - x_a))) & - + log(cosh(a_x*(x_cb(i) - x_b))) & - - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) + x_cb(i) = x_cb(i)/a_x*(a_x + log(cosh(a_x*(x_cb(i) - x_a))) + log(cosh(a_x*(x_cb(i) - x_b))) & + & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) end do end do x_cb = x_cb*length @@ -82,15 +68,13 @@ impure subroutine s_generate_serial_grid dx = minval(x_cb(0:m) - x_cb(-1:m - 1)) print *, 'Stretched grid: min/max x grid: ', minval(x_cc(:)), maxval(x_cc(:)) if (num_procs > 1) call s_mpi_reduce_min(dx) - end if ! Grid Generation in the y-direction if (n == 0) return if (grid_geometry == 2 .and. f_approx_equal(y_domain%beg, 0.0_wp)) then - !IF (grid_geometry == 2) THEN - + ! IF (grid_geometry == 2) THEN dy = (y_domain%end - y_domain%beg)/real(2*n + 1, wp) y_cc(0) = y_domain%beg + 5.e-1_wp*dy @@ -100,7 +84,6 @@ impure subroutine s_generate_serial_grid y_cc(i) = y_domain%beg + 2._wp*dy*real(i, wp) y_cb(i - 1) = y_domain%beg + dy*real(2*i - 1, wp) end do - else dy = (y_domain%end - y_domain%beg)/real(n + 1, wp) @@ -109,13 +92,11 @@ impure subroutine s_generate_serial_grid y_cc(i) = y_domain%beg + 5.e-1_wp*dy*real(2*i + 1, wp) y_cb(i - 1) = y_domain%beg + dy*real(i, wp) end do - end if y_cb(n) = y_domain%end if (stretch_y) then - length = abs(y_cb(n) - y_cb(-1)) y_cb = y_cb/length y_a = y_a/length @@ -123,10 +104,8 @@ impure subroutine s_generate_serial_grid do j = 1, loops_y do i = -1, n - y_cb(i) = y_cb(i)/a_y* & - (a_y + log(cosh(a_y*(y_cb(i) - y_a))) & - + log(cosh(a_y*(y_cb(i) - y_b))) & - - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) + y_cb(i) = y_cb(i)/a_y*(a_y + log(cosh(a_y*(y_cb(i) - y_a))) + log(cosh(a_y*(y_cb(i) - y_b))) & + & - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) end do end do @@ -136,7 +115,6 @@ impure subroutine s_generate_serial_grid dy = minval(y_cb(0:n) - y_cb(-1:n - 1)) if (num_procs > 1) call s_mpi_reduce_min(dy) - end if ! Grid Generation in the z-direction @@ -152,7 +130,6 @@ impure subroutine s_generate_serial_grid z_cb(p) = z_domain%end if (stretch_z) then - length = abs(z_cb(p) - z_cb(-1)) z_cb = z_cb/length z_a = z_a/length @@ -160,10 +137,8 @@ impure subroutine s_generate_serial_grid do j = 1, loops_z do i = -1, p - z_cb(i) = z_cb(i)/a_z* & - (a_z + log(cosh(a_z*(z_cb(i) - z_a))) & - + log(cosh(a_z*(z_cb(i) - z_b))) & - - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) + z_cb(i) = z_cb(i)/a_z*(a_z + log(cosh(a_z*(z_cb(i) - z_a))) + log(cosh(a_z*(z_cb(i) - z_b))) & + & - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) end do end do @@ -173,18 +148,12 @@ impure subroutine s_generate_serial_grid dz = minval(z_cb(0:p) - z_cb(-1:p - 1)) if (num_procs > 1) call s_mpi_reduce_min(dz) - end if - end subroutine s_generate_serial_grid - - !> The following subroutine generates either a uniform or - !! non-uniform rectilinear grid in parallel, defined by the parameters - !! inputted by the user. The grid information is stored in - !! the grid variables containing coordinates of the cell- - !! centers and cell-boundaries. + !> The following subroutine generates either a uniform or non-uniform rectilinear grid in parallel, defined by the parameters + !! inputted by the user. The grid information is stored in the grid variables containing coordinates of the cell- centers and + !! cell-boundaries. impure subroutine s_generate_parallel_grid - #ifdef MFC_MPI real(wp) :: length !< domain lengths @@ -196,10 +165,9 @@ impure subroutine s_generate_parallel_grid character(LEN=path_len + name_len) :: file_loc !< !! Generic string used to store the address of a file - integer :: ifile, ierr, data_size + integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status - - integer :: i, j !< Generic loop integers + integer :: i, j !< Generic loop integers allocate (x_cb_glb(-1:m_glb)) allocate (y_cb_glb(-1:n_glb)) @@ -221,20 +189,16 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_x do i = -1, m_glb - x_cb_glb(i) = x_cb_glb(i)/a_x* & - (a_x + log(cosh(a_x*(x_cb_glb(i) - x_a))) & - + log(cosh(a_x*(x_cb_glb(i) - x_b))) & - - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) + x_cb_glb(i) = x_cb_glb(i)/a_x*(a_x + log(cosh(a_x*(x_cb_glb(i) - x_a))) + log(cosh(a_x*(x_cb_glb(i) - x_b))) & + & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) end do end do x_cb_glb = x_cb_glb*length - end if ! Grid generation in the y-direction if (n_glb > 0) then - if (grid_geometry == 2 .and. f_approx_equal(y_domain%beg, 0.0_wp)) then dy = (y_domain%end - y_domain%beg)/real(2*n_glb + 1, wp) y_cb_glb(-1) = y_domain%beg @@ -258,15 +222,12 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_y do i = -1, n_glb - y_cb_glb(i) = y_cb_glb(i)/a_y* & - (a_y + log(cosh(a_y*(y_cb_glb(i) - y_a))) & - + log(cosh(a_y*(y_cb_glb(i) - y_b))) & - - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) + y_cb_glb(i) = y_cb_glb(i)/a_y*(a_y + log(cosh(a_y*(y_cb_glb(i) - y_a))) + log(cosh(a_y*(y_cb_glb(i) - y_b) & + & )) - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) end do end do y_cb_glb = y_cb_glb*length - end if ! Grid generation in the z-direction @@ -285,68 +246,52 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_z do i = -1, p_glb - z_cb_glb(i) = z_cb_glb(i)/a_z* & - (a_z + log(cosh(a_z*(z_cb_glb(i) - z_a))) & - + log(cosh(a_z*(z_cb_glb(i) - z_b))) & - - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) + z_cb_glb(i) = z_cb_glb(i)/a_z*(a_z + log(cosh(a_z*(z_cb_glb(i) - z_a))) + log(cosh(a_z*(z_cb_glb(i) & + & - z_b))) - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) end do end do z_cb_glb = z_cb_glb*length - end if end if end if ! Write cell boundary locations to grid data files - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'x_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'x_cb.dat' data_size = m_glb + 2 - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) call MPI_FILE_WRITE(ifile, x_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) if (n > 0) then - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'y_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'y_cb.dat' data_size = n_glb + 2 - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) call MPI_FILE_WRITE(ifile, y_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) if (p > 0) then - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'z_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'z_cb.dat' data_size = p_glb + 2 - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) call MPI_FILE_WRITE(ifile, z_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) end if end if deallocate (x_cb_glb, y_cb_glb, z_cb_glb) - #endif - end subroutine s_generate_parallel_grid - - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_grid_module - if (parallel_io .neqv. .true.) then s_generate_grid => s_generate_serial_grid else s_generate_grid => s_generate_parallel_grid end if - end subroutine s_initialize_grid_module - !> Deallocation procedures for the module impure subroutine s_finalize_grid_module - s_generate_grid => null() - end subroutine s_finalize_grid_module - end module m_grid diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 25a88f36f9..996fcc5689 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -11,10 +11,9 @@ !> @brief Constructs initial condition patch geometries (lines, circles, rectangles, spheres, etc.) on the grid module m_icpp_patches + use m_model ! Subroutine(s) related to STL files - use m_model ! Subroutine(s) related to STL files - - use m_derived_types ! Definitions of the derived types + use m_derived_types ! Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -38,8 +37,7 @@ module m_icpp_patches real(wp) :: x_centroid, y_centroid, z_centroid real(wp) :: length_x, length_y, length_z - - integer :: smooth_patch_id + integer :: smooth_patch_id real(wp) :: smooth_coeff !< !! These variables are analogous in both meaning and use to the similarly !! named components in the ic_patch_parameters type (see m_derived_types.f90 @@ -64,12 +62,10 @@ module m_icpp_patches !! perform the actions necessary to lay out a particular patch on the grid. character(len=5) :: istr ! string to store int to string result for error checking - contains !> @brief Dispatches each initial condition patch to its geometry-specific initialization routine. impure subroutine s_apply_icpp_patches(patch_id_fp, q_prim_vf) - type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -80,9 +76,7 @@ contains ! 3D Patch Geometries if (p > 0) then - do i = 1, num_patches - if (proc_rank == 0) then print *, 'Processing patch', i end if @@ -93,35 +87,33 @@ contains if (patch_icpp(i)%geometry == 8) then call s_icpp_sphere(i, patch_id_fp, q_prim_vf) ! Cuboidal patch - elseif (patch_icpp(i)%geometry == 9) then + else if (patch_icpp(i)%geometry == 9) then call s_icpp_cuboid(i, patch_id_fp, q_prim_vf) ! Cylindrical patch - elseif (patch_icpp(i)%geometry == 10) then + else if (patch_icpp(i)%geometry == 10) then call s_icpp_cylinder(i, patch_id_fp, q_prim_vf) ! Swept plane patch - elseif (patch_icpp(i)%geometry == 11) then + else if (patch_icpp(i)%geometry == 11) then call s_icpp_sweep_plane(i, patch_id_fp, q_prim_vf) ! Ellipsoidal patch - elseif (patch_icpp(i)%geometry == 12) then + else if (patch_icpp(i)%geometry == 12) then call s_icpp_ellipsoid(i, patch_id_fp, q_prim_vf) ! 3D spherical harmonic patch - elseif (patch_icpp(i)%geometry == 14) then + else if (patch_icpp(i)%geometry == 14) then call s_icpp_3d_spherical_harmonic(i, patch_id_fp, q_prim_vf) ! 3D Modified circular patch - elseif (patch_icpp(i)%geometry == 19) then + else if (patch_icpp(i)%geometry == 19) then call s_icpp_3dvarcircle(i, patch_id_fp, q_prim_vf) ! 3D STL patch - elseif (patch_icpp(i)%geometry == 21) then + else if (patch_icpp(i)%geometry == 21) then call s_icpp_model(i, patch_id_fp, q_prim_vf) end if end do !> @} ! 2D Patch Geometries - elseif (n > 0) then - + else if (n > 0) then do i = 1, num_patches - if (proc_rank == 0) then print *, 'Processing patch', i end if @@ -132,32 +124,32 @@ contains if (patch_icpp(i)%geometry == 2) then call s_icpp_circle(i, patch_id_fp, q_prim_vf) ! Rectangular patch - elseif (patch_icpp(i)%geometry == 3) then + else if (patch_icpp(i)%geometry == 3) then call s_icpp_rectangle(i, patch_id_fp, q_prim_vf) ! Swept line patch - elseif (patch_icpp(i)%geometry == 4) then + else if (patch_icpp(i)%geometry == 4) then call s_icpp_sweep_line(i, patch_id_fp, q_prim_vf) ! Elliptical patch - elseif (patch_icpp(i)%geometry == 5) then + else if (patch_icpp(i)%geometry == 5) then call s_icpp_ellipse(i, patch_id_fp, q_prim_vf) ! Unimplemented patch (formerly isentropic vortex) - elseif (patch_icpp(i)%geometry == 6) then - call s_mpi_abort('This used to be the isentropic vortex patch, '// & - 'which no longer exists. See Examples. Exiting.') + else if (patch_icpp(i)%geometry == 6) then + call s_mpi_abort('This used to be the isentropic vortex patch, ' & + & // 'which no longer exists. See Examples. Exiting.') ! 2D modal (Fourier) patch - elseif (patch_icpp(i)%geometry == 13) then + else if (patch_icpp(i)%geometry == 13) then call s_icpp_2d_modal(i, patch_id_fp, q_prim_vf) ! Spiral patch - elseif (patch_icpp(i)%geometry == 17) then + else if (patch_icpp(i)%geometry == 17) then call s_icpp_spiral(i, patch_id_fp, q_prim_vf) ! Modified circular patch - elseif (patch_icpp(i)%geometry == 18) then + else if (patch_icpp(i)%geometry == 18) then call s_icpp_varcircle(i, patch_id_fp, q_prim_vf) ! TaylorGreen vortex patch - elseif (patch_icpp(i)%geometry == 20) then + else if (patch_icpp(i)%geometry == 20) then call s_icpp_2D_TaylorGreen_vortex(i, patch_id_fp, q_prim_vf) ! STL patch - elseif (patch_icpp(i)%geometry == 21) then + else if (patch_icpp(i)%geometry == 21) then call s_icpp_model(i, patch_id_fp, q_prim_vf) end if !> @} @@ -167,7 +159,6 @@ contains else do i = 1, num_patches - if (proc_rank == 0) then print *, 'Processing patch', i end if @@ -176,26 +167,19 @@ contains if (patch_icpp(i)%geometry == 1) then call s_icpp_line_segment(i, patch_id_fp, q_prim_vf) ! 1d analytical - elseif (patch_icpp(i)%geometry == 16) then + else if (patch_icpp(i)%geometry == 16) then call s_icpp_1d_bubble_pulse(i, patch_id_fp, q_prim_vf) end if end do - end if - end subroutine s_apply_icpp_patches - - !> The line segment patch is a 1D geometry that may be used, - !! for example, in creating a Riemann problem. The geometry - !! of the patch is well-defined when its centroid and length - !! in the x-coordinate direction are provided. Note that the - !! line segment patch DOES NOT allow for the smearing of its - !! boundaries. + !> The line segment patch is a 1D geometry that may be used, for example, in creating a Riemann problem. The geometry of the + !! patch is well-defined when its centroid and length in the x-coordinate direction are provided. Note that the line segment + !! patch DOES NOT allow for the smearing of its boundaries. !! @param patch_id patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_line_segment(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -238,12 +222,9 @@ contains ! to write to that cell. If both queries check out, the primitive ! variables of the current patch are assigned to this cell. do i = 0, m - if (x_boundary%beg <= x_cc(i) .and. & - x_boundary%end >= x_cc(i) .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, 0, 0))) then - - call s_assign_patch_primitive_variables(patch_id, i, 0, 0, & - eta, q_prim_vf, patch_id_fp) + if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, & + & 0, 0))) then + call s_assign_patch_primitive_variables(patch_id, i, 0, 0, eta, q_prim_vf, patch_id_fp) @:analytical() @@ -254,22 +235,16 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < sgm_eps) patch_id_fp(i, 0, 0) = patch_id - end if end do @:HardcodedDellacation() - end subroutine s_icpp_line_segment - - !> The spiral patch is a 2D geometry that may be used, The geometry - !! of the patch is well-defined when its centroid and radius - !! are provided. Note that the circular patch DOES allow for - !! the smoothing of its boundary. + !> The spiral patch is a 2D geometry that may be used, The geometry of the patch is well-defined when its centroid and radius + !! are provided. Note that the circular patch DOES allow for the smoothing of its boundary. !! @param patch_id patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables impure subroutine s_icpp_spiral(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -277,10 +252,9 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i, j, k !< Generic loop iterators - real(wp) :: th, thickness, nturns, mya - real(wp) :: spiral_x_min, spiral_x_max, spiral_y_min, spiral_y_max + integer :: i, j, k !< Generic loop iterators + real(wp) :: th, thickness, nturns, mya + real(wp) :: spiral_x_min, spiral_x_max, spiral_y_min, spiral_y_max @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -297,29 +271,24 @@ contains do k = 0, int(m*91*nturns) th = k/real(int(m*91._wp*nturns))*nturns*2._wp*pi - spiral_x_min = minval((/f_r(th, 0.0_wp, mya)*cos(th), & - f_r(th, thickness, mya)*cos(th)/)) - spiral_y_min = minval((/f_r(th, 0.0_wp, mya)*sin(th), & - f_r(th, thickness, mya)*sin(th)/)) + spiral_x_min = minval((/f_r(th, 0.0_wp, mya)*cos(th), f_r(th, thickness, mya)*cos(th)/)) + spiral_y_min = minval((/f_r(th, 0.0_wp, mya)*sin(th), f_r(th, thickness, mya)*sin(th)/)) - spiral_x_max = maxval((/f_r(th, 0.0_wp, mya)*cos(th), & - f_r(th, thickness, mya)*cos(th)/)) - spiral_y_max = maxval((/f_r(th, 0.0_wp, mya)*sin(th), & - f_r(th, thickness, mya)*sin(th)/)) + spiral_x_max = maxval((/f_r(th, 0.0_wp, mya)*cos(th), f_r(th, thickness, mya)*cos(th)/)) + spiral_y_max = maxval((/f_r(th, 0.0_wp, mya)*sin(th), f_r(th, thickness, mya)*sin(th)/)) - do j = 0, n; do i = 0, m; - if ((x_cc(i) > spiral_x_min) .and. (x_cc(i) < spiral_x_max) .and. & - (y_cc(j) > spiral_y_min) .and. (y_cc(j) < spiral_y_max)) then - logic_grid(i, j, 0) = 1 - end if - end do; end do + do j = 0, n; do i = 0, m; + if ((x_cc(i) > spiral_x_min) .and. (x_cc(i) < spiral_x_max) .and. (y_cc(j) > spiral_y_min) .and. (y_cc(j) & + & < spiral_y_max)) then + logic_grid(i, j, 0) = 1 + end if + end do; end do end do do j = 0, n do i = 0, m if ((logic_grid(i, j, 0) == 1)) then - call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + call s_assign_patch_primitive_variables(patch_id, i, j, 0, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -332,19 +301,14 @@ contains end do end do @:HardcodedDellacation() - end subroutine s_icpp_spiral - - !> The circular patch is a 2D geometry that may be used, for - !! example, in creating a bubble or a droplet. The geometry - !! of the patch is well-defined when its centroid and radius - !! are provided. Note that the circular patch DOES allow for - !! the smoothing of its boundary. + !> The circular patch is a 2D geometry that may be used, for example, in creating a bubble or a droplet. The geometry of the + !! patch is well-defined when its centroid and radius are provided. Note that the circular patch DOES allow for the smoothing of + !! its boundary. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_circle(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -352,10 +316,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - real(wp) :: radius - - integer :: i, j, k !< Generic loop iterators + real(wp) :: radius + integer :: i, j, k !< Generic loop iterators @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -380,46 +342,29 @@ contains do j = 0, n do i = 0, m - if (patch_icpp(patch_id)%smoothen) then - - eta = tanh(smooth_coeff/min(dx, dy)* & - (sqrt((x_cc(i) - x_centroid)**2 & - + (y_cc(j) - y_centroid)**2) & - - radius))*(-0.5_wp) + 0.5_wp - + eta = tanh(smooth_coeff/min(dx, & + & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp end if - if (((x_cc(i) - x_centroid)**2 & - + (y_cc(j) - y_centroid)**2 <= radius**2 & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & - .or. & - patch_id_fp(i, j, 0) == smooth_patch_id) & - then - - call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + if (((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2 <= radius**2 .and. patch_icpp(patch_id) & + & %alter_patch(patch_id_fp(i, j, 0))) .or. patch_id_fp(i, j, 0) == smooth_patch_id) then + call s_assign_patch_primitive_variables(patch_id, i, j, 0, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @:Hardcoded2D() end if - end if end do end do @:HardcodedDellacation() - end subroutine s_icpp_circle - - !> The varcircle patch is a 2D geometry that may be used - !! . It generatres an annulus + !> The varcircle patch is a 2D geometry that may be used . It generatres an annulus !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_varcircle(patch_id, patch_id_fp, q_prim_vf) - ! Patch identifier integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION @@ -430,7 +375,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf ! Generic loop iterators - integer :: i, j, k + integer :: i, j, k real(wp) :: radius, myr, thickness @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -455,15 +400,11 @@ contains ! the current patch are assigned to this cell. do j = 0, n do i = 0, m - myr = sqrt((x_cc(i) - x_centroid)**2 & - + (y_cc(j) - y_centroid)**2) - - if (myr <= radius + thickness/2._wp .and. & - myr >= radius - thickness/2._wp .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) then + myr = sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) - call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + if (myr <= radius + thickness/2._wp .and. myr >= radius - thickness/2._wp .and. patch_icpp(patch_id) & + & %alter_patch(patch_id_fp(i, j, 0))) then + call s_assign_patch_primitive_variables(patch_id, i, j, 0, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -473,22 +414,18 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < sgm_eps) patch_id_fp(i, j, 0) = patch_id - q_prim_vf(alf_idx)%sf(i, j, 0) = patch_icpp(patch_id)%alpha(1)* & - exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) + q_prim_vf(alf_idx)%sf(i, j, & + & 0) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) end if - end do end do @:HardcodedDellacation() - end subroutine s_icpp_varcircle - !> @brief Initializes a 3D variable-thickness circular annulus patch extruded along the z-axis. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_3dvarcircle(patch_id, patch_id_fp, q_prim_vf) - ! Patch identifier integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION @@ -499,7 +436,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf ! Generic loop iterators - integer :: i, j, k + integer :: i, j, k real(wp) :: radius, myr, thickness @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -529,15 +466,11 @@ contains do k = 0, p do j = 0, n do i = 0, m - myr = sqrt((x_cc(i) - x_centroid)**2 & - + (y_cc(j) - y_centroid)**2) + myr = sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) - if (myr <= radius + thickness/2._wp .and. & - myr >= radius - thickness/2._wp .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) then - - call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + if (myr <= radius + thickness/2._wp .and. myr >= radius - thickness/2._wp .and. patch_icpp(patch_id) & + & %alter_patch(patch_id_fp(i, j, k))) then + call s_assign_patch_primitive_variables(patch_id, i, j, k, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -547,26 +480,20 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < sgm_eps) patch_id_fp(i, j, k) = patch_id - q_prim_vf(alf_idx)%sf(i, j, k) = patch_icpp(patch_id)%alpha(1)* & - exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) + q_prim_vf(alf_idx)%sf(i, j, & + & k) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) end if - end do end do end do @:HardcodedDellacation() - end subroutine s_icpp_3dvarcircle - - !> The elliptical patch is a 2D geometry. The geometry of - !! the patch is well-defined when its centroid and radii - !! are provided. Note that the elliptical patch DOES allow - !! for the smoothing of its boundary + !> The elliptical patch is a 2D geometry. The geometry of the patch is well-defined when its centroid and radii are provided. + !! Note that the elliptical patch DOES allow for the smoothing of its boundary !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_ellipse(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -574,9 +501,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i, j, k !< Generic loop operators - real(wp) :: a, b + integer :: i, j, k !< Generic loop operators + real(wp) :: a, b @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -601,24 +527,15 @@ contains ! variables of the current patch are assigned to this cell. do j = 0, n do i = 0, m - if (patch_icpp(patch_id)%smoothen) then - eta = tanh(smooth_coeff/min(dx, dy)* & - (sqrt(((x_cc(i) - x_centroid)/a)**2 + & - ((y_cc(j) - y_centroid)/b)**2) & - - 1._wp))*(-0.5_wp) + 0.5_wp + eta = tanh(smooth_coeff/min(dx, & + & dy)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((y_cc(j) - y_centroid)/b)**2) - 1._wp))*(-0.5_wp) & + & + 0.5_wp end if - if ((((x_cc(i) - x_centroid)/a)**2 + & - ((y_cc(j) - y_centroid)/b)**2 <= 1._wp & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & - .or. & - patch_id_fp(i, j, 0) == smooth_patch_id) & - then - - call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + if ((((x_cc(i) - x_centroid)/a)**2 + ((y_cc(j) - y_centroid)/b)**2 <= 1._wp .and. patch_icpp(patch_id) & + & %alter_patch(patch_id_fp(i, j, 0))) .or. patch_id_fp(i, j, 0) == smooth_patch_id) then + call s_assign_patch_primitive_variables(patch_id, i, j, 0, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -631,18 +548,13 @@ contains end do end do @:HardcodedDellacation() - end subroutine s_icpp_ellipse - - !> The ellipsoidal patch is a 3D geometry. The geometry of - !! the patch is well-defined when its centroid and radii - !! are provided. Note that the ellipsoidal patch DOES allow - !! for the smoothing of its boundary + !> The ellipsoidal patch is a 3D geometry. The geometry of the patch is well-defined when its centroid and radii are provided. + !! Note that the ellipsoidal patch DOES allow for the smoothing of its boundary !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_ellipsoid(patch_id, patch_id_fp, q_prim_vf) - ! Patch identifier integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION @@ -653,7 +565,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf ! Generic loop iterators - integer :: i, j, k + integer :: i, j, k real(wp) :: a, b, c @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -682,7 +594,6 @@ contains do k = 0, p do j = 0, n do i = 0, m - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -691,24 +602,15 @@ contains end if if (patch_icpp(patch_id)%smoothen) then - eta = tanh(smooth_coeff/min(dx, dy, dz)* & - (sqrt(((x_cc(i) - x_centroid)/a)**2 + & - ((cart_y - y_centroid)/b)**2 + & - ((cart_z - z_centroid)/c)**2) & - - 1._wp))*(-0.5_wp) + 0.5_wp + eta = tanh(smooth_coeff/min(dx, dy, & + & dz)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((cart_y - y_centroid)/b)**2 + ((cart_z & + & - z_centroid)/c)**2) - 1._wp))*(-0.5_wp) + 0.5_wp end if - if ((((x_cc(i) - x_centroid)/a)**2 + & - ((cart_y - y_centroid)/b)**2 + & - ((cart_z - z_centroid)/c)**2 <= 1._wp & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & - .or. & - patch_id_fp(i, j, k) == smooth_patch_id) & - then - - call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + if ((((x_cc(i) - x_centroid)/a)**2 + ((cart_y - y_centroid)/b)**2 + ((cart_z - z_centroid)/c) & + & **2 <= 1._wp .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) .or. patch_id_fp(i, j, & + & k) == smooth_patch_id) then + call s_assign_patch_primitive_variables(patch_id, i, j, k, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -722,22 +624,15 @@ contains end do end do @:HardcodedDellacation() - end subroutine s_icpp_ellipsoid - - !> The rectangular patch is a 2D geometry that may be used, - !! for example, in creating a solid boundary, or pre-/post- - !! shock region, in alignment with the axes of the Cartesian - !! coordinate system. The geometry of such a patch is well- - !! defined when its centroid and lengths in the x- and y- - !! coordinate directions are provided. Please note that the - !! rectangular patch DOES NOT allow for the smoothing of its - !! boundaries. + !> The rectangular patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock + !! region, in alignment with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its + !! centroid and lengths in the x- and y- coordinate directions are provided. Please note that the rectangular patch DOES NOT + !! allow for the smoothing of its boundaries. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_rectangle(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -745,9 +640,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i, j, k !< generic loop iterators - real(wp) :: pi_inf, gamma, lit_gamma !< Equation of state parameters + integer :: i, j, k !< generic loop iterators + real(wp) :: pi_inf, gamma, lit_gamma !< Equation of state parameters @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -780,15 +674,10 @@ contains ! variables of the current patch are assigned to this cell. do j = 0, n do i = 0, m - if (x_boundary%beg <= x_cc(i) .and. & - x_boundary%end >= x_cc(i) .and. & - y_boundary%beg <= y_cc(j) .and. & - y_boundary%end >= y_cc(j)) then - if (patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & - then - - call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. y_boundary%beg <= y_cc(j) & + & .and. y_boundary%end >= y_cc(j)) then + if (patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) then + call s_assign_patch_primitive_variables(patch_id, i, j, 0, eta, q_prim_vf, patch_id_fp) @:analytical() @@ -797,10 +686,10 @@ contains end if if ((q_prim_vf(1)%sf(i, j, 0) < 1.e-10) .and. (model_eqns == 4)) then - !zero density, reassign according to Tait EOS - q_prim_vf(1)%sf(i, j, 0) = & - (((q_prim_vf(E_idx)%sf(i, j, 0) + pi_inf)/(pref + pi_inf))**(1._wp/lit_gamma))* & - rhoref*(1._wp - q_prim_vf(alf_idx)%sf(i, j, 0)) + ! zero density, reassign according to Tait EOS + q_prim_vf(1)%sf(i, j, 0) = (((q_prim_vf(E_idx)%sf(i, j, & + & 0) + pi_inf)/(pref + pi_inf))**(1._wp/lit_gamma))*rhoref*(1._wp - q_prim_vf(alf_idx) & + & %sf(i, j, 0)) end if ! Updating the patch identities bookkeeping variable @@ -810,21 +699,15 @@ contains end do end do @:HardcodedDellacation() - end subroutine s_icpp_rectangle - - !> The swept line patch is a 2D geometry that may be used, - !! for example, in creating a solid boundary, or pre-/post- - !! shock region, at an angle with respect to the axes of the - !! Cartesian coordinate system. The geometry of the patch is - !! well-defined when its centroid and normal vector, aimed - !! in the sweep direction, are provided. Note that the sweep - !! line patch DOES allow the smoothing of its boundary. + !> The swept line patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock + !! region, at an angle with respect to the axes of the Cartesian coordinate system. The geometry of the patch is well-defined + !! when its centroid and normal vector, aimed in the sweep direction, are provided. Note that the sweep line patch DOES allow + !! the smoothing of its boundary. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_sweep_line(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -832,9 +715,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i, j, k !< Generic loop operators - real(wp) :: a, b, c + integer :: i, j, k !< Generic loop operators + real(wp) :: a, b, c @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -860,21 +742,13 @@ contains ! primitive variables of the current patch are written to this cell. do j = 0, n do i = 0, m - if (patch_icpp(patch_id)%smoothen) then - eta = 5.e-1_wp + 5.e-1_wp*tanh(smooth_coeff/min(dx, dy) & - *(a*x_cc(i) + b*y_cc(j) + c) & - /sqrt(a**2 + b**2)) + eta = 5.e-1_wp + 5.e-1_wp*tanh(smooth_coeff/min(dx, dy)*(a*x_cc(i) + b*y_cc(j) + c)/sqrt(a**2 + b**2)) end if - if ((a*x_cc(i) + b*y_cc(j) + c >= 0._wp & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & - .or. & - patch_id_fp(i, j, 0) == smooth_patch_id) & - then - call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + if ((a*x_cc(i) + b*y_cc(j) + c >= 0._wp .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, & + & 0))) .or. patch_id_fp(i, j, 0) == smooth_patch_id) then + call s_assign_patch_primitive_variables(patch_id, i, j, 0, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -884,22 +758,16 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < sgm_eps) patch_id_fp(i, j, 0) = patch_id end if - end do end do @:HardcodedDellacation() - end subroutine s_icpp_sweep_line - - !> The Taylor Green vortex is 2D decaying vortex that may be used, - !! for example, to verify the effects of viscous attenuation. - !! Geometry of the patch is well-defined when its centroid - !! are provided. + !> The Taylor Green vortex is 2D decaying vortex that may be used, for example, to verify the effects of viscous attenuation. + !! Geometry of the patch is well-defined when its centroid are provided. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_2D_TaylorGreen_Vortex(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -907,10 +775,9 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i, j, k !< generic loop iterators - real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters - real(wp) :: L0, U0 !< Taylor Green Vortex parameters + integer :: i, j, k !< generic loop iterators + real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters + real(wp) :: L0, U0 !< Taylor Green Vortex parameters @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -947,14 +814,9 @@ contains ! to this cell. do j = 0, n do i = 0, m - if (x_boundary%beg <= x_cc(i) .and. & - x_boundary%end >= x_cc(i) .and. & - y_boundary%beg <= y_cc(j) .and. & - y_boundary%end >= y_cc(j) .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) then - - call s_assign_patch_primitive_variables(patch_id, i, j, 0, & - eta, q_prim_vf, patch_id_fp) + if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. y_boundary%beg <= y_cc(j) & + & .and. y_boundary%end >= y_cc(j) .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) then + call s_assign_patch_primitive_variables(patch_id, i, j, 0, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -967,16 +829,14 @@ contains ! Assign Parameters q_prim_vf(mom_idx%beg)%sf(i, j, 0) = U0*sin(x_cc(i)/L0)*cos(y_cc(j)/L0) q_prim_vf(mom_idx%end)%sf(i, j, 0) = -U0*cos(x_cc(i)/L0)*sin(y_cc(j)/L0) - q_prim_vf(E_idx)%sf(i, j, 0) = patch_icpp(patch_id)%pres + (cos(2*x_cc(i))/L0 + & - cos(2*y_cc(j))/L0)* & - (q_prim_vf(1)%sf(i, j, 0)*U0*U0)/16 + q_prim_vf(E_idx)%sf(i, j, & + & 0) = patch_icpp(patch_id)%pres + (cos(2*x_cc(i))/L0 + cos(2*y_cc(j))/L0)*(q_prim_vf(1)%sf(i, j, & + & 0)*U0*U0)/16 end if end do end do @:HardcodedDellacation() - end subroutine s_icpp_2D_TaylorGreen_Vortex - !> @brief Initializes a 1D bubble-pulse patch with analytical primitive variable profiles. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids @@ -1025,28 +885,22 @@ contains ! to write to that cell. If both queries check out, the primitive ! variables of the current patch are assigned to this cell. do i = 0, m - if (x_boundary%beg <= x_cc(i) .and. & - x_boundary%end >= x_cc(i) .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, 0, 0))) then - - call s_assign_patch_primitive_variables(patch_id, i, 0, 0, & - eta, q_prim_vf, patch_id_fp) + if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, & + & 0, 0))) then + call s_assign_patch_primitive_variables(patch_id, i, 0, 0, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @:Hardcoded1D() end if - end if end do @:HardcodedDellacation() - end subroutine s_icpp_1D_bubble_pulse - - !> 2D modal (Fourier) patch. theta = atan2(y - y_centroid, x - x_centroid). - !! Additive (modal_use_exp_form false): R = radius + sum_n [fourier_cos*cos(n*theta)+fourier_sin*sin(n*theta)]; - !! coefficients are absolute (same units as radius). R is clipped to max(R,0). If modal_clip_r_to_min, R = max(R, modal_r_min). - !! Exponential (modal_use_exp_form true): R = radius*exp(sum); coefficients are relative (dimensionless). + !> 2D modal (Fourier) patch. theta = atan2(y - y_centroid, x - x_centroid). Additive (modal_use_exp_form false): R = radius + + !! sum_n [fourier_cos*cos(n*theta)+fourier_sin*sin(n*theta)]; coefficients are absolute (same units as radius). R is clipped to + !! max(R,0). If modal_clip_r_to_min, R = max(R, modal_r_min). Exponential (modal_use_exp_form true): R = radius*exp(sum); + !! coefficients are relative (dimensionless). subroutine s_icpp_2d_modal(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION @@ -1055,9 +909,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - real(wp) :: r, theta, R_boundary, sum_series - integer :: i, j, nn + real(wp) :: r, theta, R_boundary, sum_series + integer :: i, j, nn x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid @@ -1075,8 +928,8 @@ contains end if sum_series = 0._wp do nn = 1, max_2d_fourier_modes - sum_series = sum_series + patch_icpp(patch_id)%fourier_cos(nn)*cos(real(nn, wp)*theta) & - + patch_icpp(patch_id)%fourier_sin(nn)*sin(real(nn, wp)*theta) + sum_series = sum_series + patch_icpp(patch_id)%fourier_cos(nn)*cos(real(nn, & + & wp)*theta) + patch_icpp(patch_id)%fourier_sin(nn)*sin(real(nn, wp)*theta) end do if (patch_icpp(patch_id)%modal_use_exp_form) then R_boundary = patch_icpp(patch_id)%radius*exp(sum_series) @@ -1090,16 +943,15 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = 0.5_wp + 0.5_wp*tanh(smooth_coeff/min(dx, dy)*(R_boundary - r)) end if - if ((r <= R_boundary .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) & - .or. patch_id_fp(i, j, 0) == smooth_patch_id) then + if ((r <= R_boundary .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, 0))) .or. patch_id_fp(i, j, & + & 0) == smooth_patch_id) then call s_assign_patch_primitive_variables(patch_id, i, j, 0, eta, q_prim_vf, patch_id_fp) end if end do end do end subroutine s_icpp_2d_modal - - !> 3D spherical harmonic patch. Surface r = radius + sum_lm sph_har_coeff(l,m)*Y_lm(theta,phi). - !! theta = acos(z/r), phi = atan2(y,x) relative to centroid. + !> 3D spherical harmonic patch. Surface r = radius + sum_lm sph_har_coeff(l,m)*Y_lm(theta,phi). theta = acos(z/r), phi = + !! atan2(y,x) relative to centroid. subroutine s_icpp_3d_spherical_harmonic(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION @@ -1108,9 +960,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - real(wp) :: dx_loc, dy_loc, dz_loc, r, theta, phi, R_surface, eta_local - integer :: i, j, k, ll, mm + real(wp) :: dx_loc, dy_loc, dz_loc, r, theta, phi, R_surface, eta_local + integer :: i, j, k, ll, mm x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid @@ -1150,25 +1001,21 @@ contains if (patch_icpp(patch_id)%smoothen) then eta_local = 0.5_wp + 0.5_wp*tanh(smooth_coeff/min(dx, dy, dz)*(R_surface - r)) end if - if ((r <= R_surface .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & - .or. patch_id_fp(i, j, k) == smooth_patch_id) then + if ((r <= R_surface .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) .or. patch_id_fp(i, j, & + & k) == smooth_patch_id) then call s_assign_patch_primitive_variables(patch_id, i, j, k, eta_local, q_prim_vf, patch_id_fp) end if end do end do end do end subroutine s_icpp_3d_spherical_harmonic - - !> The spherical patch is a 3D geometry that may be used, - !! for example, in creating a bubble or a droplet. The patch - !! geometry is well-defined when its centroid and radius are - !! provided. Please note that the spherical patch DOES allow - !! for the smoothing of its boundary. + !> The spherical patch is a 3D geometry that may be used, for example, in creating a bubble or a droplet. The patch geometry is + !! well-defined when its centroid and radius are provided. Please note that the spherical patch DOES allow for the smoothing of + !! its boundary. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_sphere(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1178,7 +1025,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf ! Generic loop iterators - integer :: i, j, k + integer :: i, j, k real(wp) :: radius @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1207,7 +1054,6 @@ contains do k = 0, p do j = 0, n do i = 0, m - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -1216,48 +1062,34 @@ contains end if if (patch_icpp(patch_id)%smoothen) then - eta = tanh(smooth_coeff/min(dx, dy, dz)* & - (sqrt((x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2) & - - radius))*(-0.5_wp) + 0.5_wp + eta = tanh(smooth_coeff/min(dx, dy, & + & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) & + & - radius))*(-0.5_wp) + 0.5_wp end if - if ((((x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2 <= radius**2) .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) .or. & - patch_id_fp(i, j, k) == smooth_patch_id) then - - call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + if ((((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2 + (cart_z - z_centroid)**2 <= radius**2) & + & .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) .or. patch_id_fp(i, j, & + & k) == smooth_patch_id) then + call s_assign_patch_primitive_variables(patch_id, i, j, k, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @:Hardcoded3D() end if - end if end do end do end do @:HardcodedDellacation() - end subroutine s_icpp_sphere - - !> The cuboidal patch is a 3D geometry that may be used, for - !! example, in creating a solid boundary, or pre-/post-shock - !! region, which is aligned with the axes of the Cartesian - !! coordinate system. The geometry of such a patch is well- - !! defined when its centroid and lengths in the x-, y- and - !! z-coordinate directions are provided. Please notice that - !! the cuboidal patch DOES NOT allow for the smearing of its - !! boundaries. + !> The cuboidal patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post-shock region, + !! which is aligned with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its + !! centroid and lengths in the x-, y- and z-coordinate directions are provided. Please notice that the cuboidal patch DOES NOT + !! allow for the smearing of its boundaries. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_cuboid(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1265,8 +1097,7 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i, j, k !< Generic loop iterators + integer :: i, j, k !< Generic loop iterators @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1300,7 +1131,6 @@ contains do k = 0, p do j = 0, n do i = 0, m - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -1308,17 +1138,10 @@ contains cart_z = z_cc(k) end if - if (x_boundary%beg <= x_cc(i) .and. & - x_boundary%end >= x_cc(i) .and. & - y_boundary%beg <= cart_y .and. & - y_boundary%end >= cart_y .and. & - z_boundary%beg <= cart_z .and. & - z_boundary%end >= cart_z) then - + if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) & + & .and. y_boundary%beg <= cart_y .and. y_boundary%end >= cart_y .and. z_boundary%beg <= cart_z .and. z_boundary%end >= cart_z) then if (patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) then - - call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + call s_assign_patch_primitive_variables(patch_id, i, j, k, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -1327,29 +1150,21 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < sgm_eps) patch_id_fp(i, j, k) = patch_id - end if end if end do end do end do @:HardcodedDellacation() - end subroutine s_icpp_cuboid - - !> The cylindrical patch is a 3D geometry that may be used, - !! for example, in setting up a cylindrical solid boundary - !! confinement, like a blood vessel. The geometry of this - !! patch is well-defined when the centroid, the radius and - !! the length along the cylinder's axis, parallel to the x-, - !! y- or z-coordinate direction, are provided. Please note - !! that the cylindrical patch DOES allow for the smoothing - !! of its lateral boundary. + !> The cylindrical patch is a 3D geometry that may be used, for example, in setting up a cylindrical solid boundary confinement, + !! like a blood vessel. The geometry of this patch is well-defined when the centroid, the radius and the length along the + !! cylinder's axis, parallel to the x-, y- or z-coordinate direction, are provided. Please note that the cylindrical patch DOES + !! allow for the smoothing of its lateral boundary. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_cylinder(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1357,9 +1172,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i, j, k !< Generic loop iterators - real(wp) :: radius + integer :: i, j, k !< Generic loop iterators + real(wp) :: radius @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1396,7 +1210,6 @@ contains do k = 0, p do j = 0, n do i = 0, m - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -1406,45 +1219,29 @@ contains if (patch_icpp(patch_id)%smoothen) then if (.not. f_is_default(length_x)) then - eta = tanh(smooth_coeff/min(dy, dz)* & - (sqrt((cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2) & - - radius))*(-0.5_wp) + 0.5_wp - elseif (.not. f_is_default(length_y)) then - eta = tanh(smooth_coeff/min(dx, dz)* & - (sqrt((x_cc(i) - x_centroid)**2 & - + (cart_z - z_centroid)**2) & - - radius))*(-0.5_wp) + 0.5_wp + eta = tanh(smooth_coeff/min(dy, & + & dz)*(sqrt((cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) & + & + 0.5_wp + else if (.not. f_is_default(length_y)) then + eta = tanh(smooth_coeff/min(dx, & + & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) & + & + 0.5_wp else - eta = tanh(smooth_coeff/min(dx, dy)* & - (sqrt((x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2) & - - radius))*(-0.5_wp) + 0.5_wp + eta = tanh(smooth_coeff/min(dx, & + & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2) - radius))*(-0.5_wp) & + & + 0.5_wp end if end if - if (((.not. f_is_default(length_x) .and. & - (cart_y - y_centroid)**2 & - + (cart_z - z_centroid)**2 <= radius**2 .and. & - x_boundary%beg <= x_cc(i) .and. & - x_boundary%end >= x_cc(i)) & - .or. & - (.not. f_is_default(length_y) .and. & - (x_cc(i) - x_centroid)**2 & - + (cart_z - z_centroid)**2 <= radius**2 .and. & - y_boundary%beg <= cart_y .and. & - y_boundary%end >= cart_y) & - .or. & - (.not. f_is_default(length_z) .and. & - (x_cc(i) - x_centroid)**2 & - + (cart_y - y_centroid)**2 <= radius**2 .and. & - z_boundary%beg <= cart_z .and. & - z_boundary%end >= cart_z) .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) .or. & - patch_id_fp(i, j, k) == smooth_patch_id) then - - call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + if (((.not. f_is_default(length_x) .and. (cart_y - y_centroid)**2 + (cart_z - z_centroid) & + & **2 <= radius**2 .and. x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i)) & + & .or. (.not. f_is_default(length_y) .and. (x_cc(i) - x_centroid)**2 + (cart_z - z_centroid) & + & **2 <= radius**2 .and. y_boundary%beg <= cart_y .and. y_boundary%end >= cart_y) & + & .or. (.not. f_is_default(length_z) .and. (x_cc(i) - x_centroid)**2 + (cart_y - y_centroid) & + & **2 <= radius**2 .and. z_boundary%beg <= cart_z .and. z_boundary%end >= cart_z) & + & .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) .or. patch_id_fp(i, j, & + & k) == smooth_patch_id) then + call s_assign_patch_primitive_variables(patch_id, i, j, k, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -1458,21 +1255,15 @@ contains end do end do @:HardcodedDellacation() - end subroutine s_icpp_cylinder - - !> The swept plane patch is a 3D geometry that may be used, - !! for example, in creating a solid boundary, or pre-/post- - !! shock region, at an angle with respect to the axes of the - !! Cartesian coordinate system. The geometry of the patch is - !! well-defined when its centroid and normal vector, aimed - !! in the sweep direction, are provided. Note that the sweep - !! plane patch DOES allow the smoothing of its boundary. + !> The swept plane patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock + !! region, at an angle with respect to the axes of the Cartesian coordinate system. The geometry of the patch is well-defined + !! when its centroid and normal vector, aimed in the sweep direction, are provided. Note that the sweep plane patch DOES allow + !! the smoothing of its boundary. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Primitive variables subroutine s_icpp_sweep_plane(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1480,9 +1271,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - - integer :: i, j, k !< Generic loop iterators - real(wp) :: a, b, c, d + integer :: i, j, k !< Generic loop iterators + real(wp) :: a, b, c, d @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1511,7 +1301,6 @@ contains do k = 0, p do j = 0, n do i = 0, m - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -1520,22 +1309,13 @@ contains end if if (patch_icpp(patch_id)%smoothen) then - eta = 5.e-1_wp + 5.e-1_wp*tanh(smooth_coeff/min(dx, dy, dz) & - *(a*x_cc(i) + & - b*cart_y + & - c*cart_z + d) & - /sqrt(a**2 + b**2 + c**2)) + eta = 5.e-1_wp + 5.e-1_wp*tanh(smooth_coeff/min(dx, dy, & + & dz)*(a*x_cc(i) + b*cart_y + c*cart_z + d)/sqrt(a**2 + b**2 + c**2)) end if - if ((a*x_cc(i) + b*cart_y + c*cart_z + d >= 0._wp & - .and. & - patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, k))) & - .or. & - patch_id_fp(i, j, k) == smooth_patch_id) & - then - - call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + if ((a*x_cc(i) + b*cart_y + c*cart_z + d >= 0._wp .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, & + & k))) .or. patch_id_fp(i, j, k) == smooth_patch_id) then + call s_assign_patch_primitive_variables(patch_id, i, j, k, eta, q_prim_vf, patch_id_fp) @:analytical() if (patch_icpp(patch_id)%hcid /= dflt_int) then @@ -1545,20 +1325,16 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < sgm_eps) patch_id_fp(i, j, k) = patch_id end if - end do end do end do @:HardcodedDellacation() - end subroutine s_icpp_sweep_plane - !> The STL patch is a 2/3D geometry that is imported from an STL file. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Primitive variables subroutine s_icpp_model(patch_id, patch_id_fp, q_prim_vf) - integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1568,29 +1344,23 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf ! Variables for IBM+STL - real(wp) :: normals(1:3) !< Boundary normal buffer - integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex - real(wp), allocatable, dimension(:, :, :) :: boundary_v !< Boundary vertex buffer - real(wp) :: distance !< Levelset distance buffer - logical :: interpolate !< Logical variable to determine whether or not the model should be interpolated - - integer :: i, j, k !< Generic loop iterators - - type(t_bbox) :: bbox, bbox_old - type(t_model) :: model - type(ic_model_parameters) :: params - - real(wp), dimension(1:3) :: point, model_center - - real(wp) :: grid_mm(1:3, 1:2) - - integer :: cell_num - integer :: ncells - - real(wp), dimension(1:4, 1:4) :: transform, transform_n + real(wp) :: normals(1:3) !< Boundary normal buffer + integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex + real(wp), allocatable, dimension(:,:,:) :: boundary_v !< Boundary vertex buffer + real(wp) :: distance !< Levelset distance buffer + logical :: interpolate !< Logical variable to determine whether or not the model should be interpolated + integer :: i, j, k !< Generic loop iterators + type(t_bbox) :: bbox, bbox_old + type(t_model) :: model + type(ic_model_parameters) :: params + real(wp), dimension(1:3) :: point, model_center + real(wp) :: grid_mm(1:3, 1:2) + integer :: cell_num + integer :: ncells + real(wp), dimension(1:4, 1:4) :: transform, transform_n if (proc_rank == 0) then - print *, " * Reading model: "//trim(patch_icpp(patch_id)%model_filepath) + print *, " * Reading model: " // trim(patch_icpp(patch_id)%model_filepath) end if model = f_model_read(patch_icpp(patch_id)%model_filepath) @@ -1634,16 +1404,16 @@ contains write (*, "(A, 3(2X, F20.10))") " > Cen:", (bbox%min(1:3) + bbox%max(1:3))/2._wp write (*, "(A, 3(2X, F20.10))") " > Max:", bbox%max(1:3) - !call s_model_write("__out__.stl", model) - !call s_model_write("__out__.obj", model) + ! call s_model_write("__out__.stl", model) + ! call s_model_write("__out__.obj", model) - grid_mm(1, :) = (/minval(x_cc) - 0.e5_wp*dx, maxval(x_cc) + 0.e5_wp*dx/) - grid_mm(2, :) = (/minval(y_cc) - 0.e5_wp*dy, maxval(y_cc) + 0.e5_wp*dy/) + grid_mm(1,:) = (/minval(x_cc) - 0.e5_wp*dx, maxval(x_cc) + 0.e5_wp*dx/) + grid_mm(2,:) = (/minval(y_cc) - 0.e5_wp*dy, maxval(y_cc) + 0.e5_wp*dy/) if (p > 0) then - grid_mm(3, :) = (/minval(z_cc) - 0.e5_wp*dz, maxval(z_cc) + 0.e5_wp*dz/) + grid_mm(3,:) = (/minval(z_cc) - 0.e5_wp*dz, maxval(z_cc) + 0.e5_wp*dz/) else - grid_mm(3, :) = (/0._wp, 0._wp/) + grid_mm(3,:) = (/0._wp, 0._wp/) end if write (*, "(A, 3(2X, F20.10))") " > Domain: Min:", grid_mm(:, 1) @@ -1653,38 +1423,34 @@ contains ncells = (m + 1)*(n + 1)*(p + 1) do i = 0, m; do j = 0, n; do k = 0, p + cell_num = i*(n + 1)*(p + 1) + j*(p + 1) + (k + 1) + if (proc_rank == 0 .and. mod(cell_num, ncells/100) == 0) then + write (*, "(A, I3, A)", advance="no") char(13) // " * Generating grid: ", nint(100*real(cell_num)/ncells), "%" + end if - cell_num = i*(n + 1)*(p + 1) + j*(p + 1) + (k + 1) - if (proc_rank == 0 .and. mod(cell_num, ncells/100) == 0) then - write (*, "(A, I3, A)", advance="no") & - char(13)//" * Generating grid: ", & - nint(100*real(cell_num)/ncells), "%" - end if - - point = (/x_cc(i), y_cc(j), 0._wp/) - if (p > 0) then - point(3) = z_cc(k) - end if + point = (/x_cc(i), y_cc(j), 0._wp/) + if (p > 0) then + point(3) = z_cc(k) + end if - if (grid_geometry == 3) then - point = f_convert_cyl_to_cart(point) - end if + if (grid_geometry == 3) then + point = f_convert_cyl_to_cart(point) + end if - eta = f_model_is_inside(model, point, (/dx, dy, dz/), patch_icpp(patch_id)%model_spc) + eta = f_model_is_inside(model, point, (/dx, dy, dz/), patch_icpp(patch_id)%model_spc) - if (eta > patch_icpp(patch_id)%model_threshold) then - eta = 1._wp - else if (.not. patch_icpp(patch_id)%smoothen) then - eta = 0._wp - end if + if (eta > patch_icpp(patch_id)%model_threshold) then + eta = 1._wp + else if (.not. patch_icpp(patch_id)%smoothen) then + eta = 0._wp + end if - call s_assign_patch_primitive_variables(patch_id, i, j, k, & - eta, q_prim_vf, patch_id_fp) + call s_assign_patch_primitive_variables(patch_id, i, j, k, eta, q_prim_vf, patch_id_fp) - ! Note: Should probably use *eta* to compute primitive variables - ! if defining them analytically. - @:analytical() - end do; end do; end do + ! Note: Should probably use *eta* to compute primitive variables + ! if defining them analytically. + @:analytical() + end do; end do; end do if (proc_rank == 0) then print *, "" @@ -1692,9 +1458,7 @@ contains end if call s_model_free(model) - end subroutine s_icpp_model - !> @brief Converts cylindrical (r, theta) coordinates to Cartesian (y, z) module variables. subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) $:GPU_ROUTINE(parallelism='[seq]') @@ -1703,48 +1467,37 @@ contains cart_y = cyl_y*sin(cyl_z) cart_z = cyl_y*cos(cyl_z) - end subroutine s_convert_cylindrical_to_cartesian_coord - !> @brief Returns a 3D Cartesian coordinate vector from a cylindrical (x, r, theta) input vector. function f_convert_cyl_to_cart(cyl) result(cart) - $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(1:3), intent(in) :: cyl - real(wp), dimension(1:3) :: cart - - cart = (/cyl(1), & - cyl(2)*sin(cyl(3)), & - cyl(2)*cos(cyl(3))/) + real(wp), dimension(1:3) :: cart + cart = (/cyl(1), cyl(2)*sin(cyl(3)), cyl(2)*cos(cyl(3))/) end function f_convert_cyl_to_cart - !> @brief Computes the spherical azimuthal angle from cylindrical (x, r) coordinates. subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(IN) :: cyl_x, cyl_y + real(wp), intent(in) :: cyl_x, cyl_y sph_phi = atan(cyl_y/cyl_x) - end subroutine s_convert_cylindrical_to_spherical_coord - !> Archimedes spiral function !! @param myth Angle !! @param offset Thickness !! @param a Starting position elemental function f_r(myth, offset, a) - $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: myth, offset, a - real(wp) :: b - real(wp) :: f_r + real(wp) :: b + real(wp) :: f_r - !r(th) = a + b*th + ! r(th) = a + b*th b = 2._wp*a/(2._wp*pi) f_r = a + b*myth + offset end function f_r - end module m_icpp_patches diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 45ad160af0..6ebcfaa4bb 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -4,23 +4,22 @@ !> @brief Assembles initial conditions by layering prioritized patches via constructive solid geometry module m_initial_condition + use m_derived_types ! Definitions of the derived types - use m_derived_types ! Definitions of the derived types - - use m_global_parameters ! Global parameters for the code + use m_global_parameters ! Global parameters for the code use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_helper - use m_variables_conversion ! Subroutines to change the state variables from + use m_variables_conversion ! Subroutines to change the state variables from ! one form to another use m_icpp_patches use m_assign_variables - use m_perturbation ! Subroutines to perturb initial flow fields + use m_perturbation ! Subroutines to perturb initial flow fields use m_chemistry @@ -32,30 +31,24 @@ module m_initial_condition ! a procedure such that the choice of the model equations does not have to ! be queried every time the patch primitive variables are to be assigned in ! a cell in the computational domain. - type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< primitive variables - - type(scalar_field), allocatable, dimension(:) :: q_cons_vf !< conservative variables - - type(scalar_field) :: q_T_sf !< Temperature field - - type(integer_field), dimension(:, :), allocatable :: bc_type !< bc_type fields + type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< primitive variables + type(scalar_field), allocatable, dimension(:) :: q_cons_vf !< conservative variables + type(scalar_field) :: q_T_sf !< Temperature field + type(integer_field), dimension(:,:), allocatable :: bc_type !< bc_type fields -!> @cond + !> @cond #ifdef MFC_MIXED_PRECISION - integer(kind=1), allocatable, dimension(:, :, :) :: patch_id_fp + integer(kind=1), allocatable, dimension(:,:,:) :: patch_id_fp #else -!> @endcond - integer, allocatable, dimension(:, :, :) :: patch_id_fp -!> @cond + !> @endcond + integer, allocatable, dimension(:,:,:) :: patch_id_fp + !> @cond #endif -!> @endcond - + !> @endcond contains - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_initial_condition_module - integer :: i, j, k, l !< generic loop iterators ! Allocating the primitive and conservative variables @@ -63,12 +56,8 @@ contains allocate (q_cons_vf(1:sys_size)) do i = 1, sys_size - allocate (q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) - allocate (q_cons_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + allocate (q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + allocate (q_cons_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do if (chemistry) then @@ -79,13 +68,9 @@ contains allocate (patch_id_fp(0:m, 0:n, 0:p)) if (qbmm .and. .not. polytropic) then - !Allocate bubble pressure pb and vapor mass mv for non-polytropic qbmm at all quad nodes and R0 bins - allocate (pb%sf(0:m, & - 0:n, & - 0:p, 1:nnode, 1:nb)) - allocate (mv%sf(0:m, & - 0:n, & - 0:p, 1:nnode, 1:nb)) + ! Allocate bubble pressure pb and vapor mass mv for non-polytropic qbmm at all quad nodes and R0 bins + allocate (pb%sf(0:m, 0:n, 0:p, 1:nnode, 1:nb)) + allocate (mv%sf(0:m, 0:n, 0:p, 1:nnode, 1:nb)) end if ! Setting default values for conservative and primitive variables so @@ -153,26 +138,17 @@ contains ! extent of application that the overwrite permissions give a patch ! when it is being applied in the domain. patch_id_fp = 0 - end subroutine s_initialize_initial_condition_module - - !> This subroutine peruses the patches and depending on the - !! type of geometry associated with a particular patch, it - !! calls the related subroutine to setup the said geometry - !! on the grid using the primitive variables included with - !! the patch parameters. The subroutine is complete once the - !! primitive variables are converted to conservative ones. + !> This subroutine peruses the patches and depending on the type of geometry associated with a particular patch, it calls the + !! related subroutine to setup the said geometry on the grid using the primitive variables included with the patch parameters. + !! The subroutine is complete once the primitive variables are converted to conservative ones. impure subroutine s_generate_initial_condition - integer :: i ! Converting the conservative variables to the primitive ones given ! preexisting initial condition data files were read in on start-up if (old_ic) then - call s_convert_conservative_to_primitive_variables(q_cons_vf, & - q_T_sf, & - q_prim_vf, & - idwbuff) + call s_convert_conservative_to_primitive_variables(q_cons_vf, q_T_sf, q_prim_vf, idwbuff) end if call s_apply_icpp_patches(patch_id_fp, q_prim_vf) @@ -191,16 +167,13 @@ contains if (chemistry) call s_compute_T_from_primitives(q_T_sf, q_prim_vf, idwint) if (qbmm .and. .not. polytropic) then - !Initialize pb and mv + ! Initialize pb and mv call s_initialize_mv(q_cons_vf, mv%sf) call s_initialize_pb(q_cons_vf, mv%sf, pb%sf) end if - end subroutine s_generate_initial_condition - - !> Deallocation procedures for the module + !> Deallocation procedures for the module impure subroutine s_finalize_initial_condition_module - integer :: i !< Generic loop iterator ! Dellocating the primitive and conservative variables @@ -233,7 +206,5 @@ contains end if deallocate (bc_type) - end subroutine s_finalize_initial_condition_module - end module m_initial_condition diff --git a/src/pre_process/m_mpi_proxy.fpp b/src/pre_process/m_mpi_proxy.fpp index 69afc99041..5c4fac4839 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -4,7 +4,6 @@ !> @brief Broadcasts user inputs and decomposes the domain across MPI ranks for pre-processing module m_mpi_proxy - #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -18,15 +17,10 @@ module m_mpi_proxy use m_mpi_common implicit none - contains - !> Since only processor with rank 0 is in charge of reading - !! and checking the consistency of the user provided inputs, - !! these are not available to the remaining processors. This - !! subroutine is then in charge of broadcasting the required - !! information. + !> Since only processor with rank 0 is in charge of reading and checking the consistency of the user provided inputs, these are + !! not available to the remaining processors. This subroutine is then in charge of broadcasting the required information. impure subroutine s_mpi_bcast_user_inputs - #ifdef MFC_MPI ! Generic loop iterator @@ -176,9 +170,6 @@ contains call MPI_BCAST(simplex_params%perturb_vel_offset(i, j), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) end do end do - #endif - end subroutine s_mpi_bcast_user_inputs - end module m_mpi_proxy diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index 2093ea30dd..47675b5173 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -4,14 +4,13 @@ !> @brief Perturbs initial mean flow fields with random noise, mixing-layer instabilities, or simplex noise module m_perturbation + use m_derived_types ! Definitions of the derived types - use m_derived_types ! Definitions of the derived types - - use m_global_parameters ! Global parameters for the code + use m_global_parameters ! Global parameters for the code use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_boundary_common ! Boundary conditions module + use m_boundary_common ! Boundary conditions module use m_helper @@ -21,27 +20,21 @@ module m_perturbation implicit none - real(wp), allocatable, dimension(:, :, :, :) :: q_prim_temp - + real(wp), allocatable, dimension(:,:,:,:) :: q_prim_temp contains !> @brief Allocates the temporary primitive variable array used by elliptic smoothing. impure subroutine s_initialize_perturbation_module() - if (elliptic_smoothing) then allocate (q_prim_temp(0:m, 0:n, 0:p, 1:sys_size)) end if - end subroutine s_initialize_perturbation_module - !> @brief Randomly perturbs partial density fields at the interface of a spherical volume fraction region. impure subroutine s_perturb_sphere(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k, l !< generic loop operators - - real(wp) :: perturb_alpha - - real(wp) :: rand_real + integer :: i, j, k, l !< generic loop operators + real(wp) :: perturb_alpha + real(wp) :: rand_real call random_seed() do k = 0, p @@ -54,26 +47,21 @@ contains ! Perturb partial density fields to match perturbed volume fraction fields ! IF ((perturb_alpha >= 25e-2_wp) .AND. (perturb_alpha <= 75e-2_wp)) THEN if ((.not. f_approx_equal(perturb_alpha, 0._wp)) .and. (.not. f_approx_equal(perturb_alpha, 1._wp))) then - ! Derive new partial densities do l = 1, num_fluids q_prim_vf(l)%sf(i, j, k) = q_prim_vf(E_idx + l)%sf(i, j, k)*fluid_rho(l) end do - end if end do end do end do - end subroutine s_perturb_sphere - !> @brief Adds random noise to the velocity and void fraction of the surrounding flow field. impure subroutine s_perturb_surrounding_flow(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< generic loop iterators - - real(wp) :: perturb_alpha - real(wp) :: rand_real + integer :: i, j, k !< generic loop iterators + real(wp) :: perturb_alpha + real(wp) :: rand_real call random_seed() ! Perturb partial density or velocity of surrounding flow by some random small amount of noise @@ -92,16 +80,13 @@ contains end do end do end subroutine s_perturb_surrounding_flow - !> @brief Iteratively smooths all primitive variable fields using a discrete elliptic (Laplacian) filter. impure subroutine s_elliptic_smoothing(q_prim_vf, bc_type) - - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - integer :: i, j, k, l, q + integer :: i, j, k, l, q do q = 1, elliptic_smoothing_iters - ! Communication of buffer regions and apply boundary conditions call s_populate_variables_buffers(bc_type, q_prim_vf, pb%sf, mv%sf) @@ -109,19 +94,17 @@ contains if (n == 0) then do j = 0, m do i = 1, sys_size - q_prim_temp(j, 0, 0, i) = (1._wp/4._wp)* & - (q_prim_vf(i)%sf(j + 1, 0, 0) + q_prim_vf(i)%sf(j - 1, 0, 0) + & - 2._wp*q_prim_vf(i)%sf(j, 0, 0)) + q_prim_temp(j, 0, 0, i) = (1._wp/4._wp)*(q_prim_vf(i)%sf(j + 1, 0, 0) + q_prim_vf(i)%sf(j - 1, 0, & + & 0) + 2._wp*q_prim_vf(i)%sf(j, 0, 0)) end do end do else if (p == 0) then do k = 0, n do j = 0, m do i = 1, sys_size - q_prim_temp(j, k, 0, i) = (1._wp/8._wp)* & - (q_prim_vf(i)%sf(j + 1, k, 0) + q_prim_vf(i)%sf(j - 1, k, 0) + & - q_prim_vf(i)%sf(j, k + 1, 0) + q_prim_vf(i)%sf(j, k - 1, 0) + & - 4._wp*q_prim_vf(i)%sf(j, k, 0)) + q_prim_temp(j, k, 0, i) = (1._wp/8._wp)*(q_prim_vf(i)%sf(j + 1, k, 0) + q_prim_vf(i)%sf(j - 1, k, & + & 0) + q_prim_vf(i)%sf(j, k + 1, 0) + q_prim_vf(i)%sf(j, k - 1, & + & 0) + 4._wp*q_prim_vf(i)%sf(j, k, 0)) end do end do end do @@ -130,11 +113,10 @@ contains do k = 0, n do j = 0, m do i = 1, sys_size - q_prim_temp(j, k, l, i) = (1._wp/12._wp)* & - (q_prim_vf(i)%sf(j + 1, k, l) + q_prim_vf(i)%sf(j - 1, k, l) + & - q_prim_vf(i)%sf(j, k + 1, l) + q_prim_vf(i)%sf(j, k - 1, l) + & - q_prim_vf(i)%sf(j, k, l + 1) + q_prim_vf(i)%sf(j, k, l - 1) + & - 6._wp*q_prim_vf(i)%sf(j, k, l)) + q_prim_temp(j, k, l, i) = (1._wp/12._wp)*(q_prim_vf(i)%sf(j + 1, k, l) + q_prim_vf(i)%sf(j - 1, & + & k, l) + q_prim_vf(i)%sf(j, k + 1, l) + q_prim_vf(i)%sf(j, k - 1, & + & l) + q_prim_vf(i)%sf(j, k, l + 1) + q_prim_vf(i)%sf(j, k, & + & l - 1) + 6._wp*q_prim_vf(i)%sf(j, k, l)) end do end do end do @@ -152,19 +134,15 @@ contains end do end do end do - end subroutine s_elliptic_smoothing - !> @brief Perturbs velocity and volume fraction fields using multi-octave simplex noise. subroutine s_perturb_simplex(q_prim_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(wp) :: mag, freq, scale, vel_rsm - real(wp), dimension(:, :), allocatable :: ofs - integer :: nOffsets - real(wp) :: xl, yl, zl - - integer :: i, j, k, l, q + real(wp) :: mag, freq, scale, vel_rsm + real(wp), dimension(:,:), allocatable :: ofs + integer :: nOffsets + real(wp) :: xl, yl, zl + integer :: i, j, k, l, q nOffsets = max(num_dims, num_fluids) @@ -189,7 +167,7 @@ contains yl = freq*(y_cc(k) + ofs(i, 2)) if (num_dims == 2) then mag = f_simplex2d(xl, yl) - elseif (num_dims == 3) then + else if (num_dims == 3) then zl = freq*(z_cc(l) + ofs(i, 3)) mag = f_simplex3d(xl, yl, zl) end if @@ -200,8 +178,7 @@ contains end do vel_rsm = sqrt(vel_rsm) - q_prim_vf(momxb + i - 1)%sf(j, k, l) = q_prim_vf(momxb + i - 1)%sf(j, k, l) + & - vel_rsm*scale*mag + q_prim_vf(momxb + i - 1)%sf(j, k, l) = q_prim_vf(momxb + i - 1)%sf(j, k, l) + vel_rsm*scale*mag end do end do end do @@ -227,12 +204,12 @@ contains yl = freq*(y_cc(k) + ofs(i, 2)) if (num_dims == 2) then mag = f_simplex2d(xl, yl) - elseif (num_dims == 3) then + else if (num_dims == 3) then zl = freq*(z_cc(l) + ofs(i, 3)) mag = f_simplex3d(xl, yl, zl) end if - q_prim_vf(contxb + i - 1)%sf(j, k, l) = q_prim_vf(contxb + i - 1)%sf(j, k, l) + & - q_prim_vf(contxb + i - 1)%sf(j, k, l)*scale*mag + q_prim_vf(contxb + i - 1)%sf(j, k, l) = q_prim_vf(contxb + i - 1)%sf(j, k, & + & l) + q_prim_vf(contxb + i - 1)%sf(j, k, l)*scale*mag end do end do end do @@ -240,21 +217,17 @@ contains end do deallocate (ofs) - end subroutine s_perturb_simplex - - !> This subroutine computes velocity perturbations for a temporal mixing - !! layer with a hyperbolic tangent mean streamwise velocity - !! profile, using an inverted version of the spectrum-based - !! synthetic turbulence generation method proposed by - !! Guo et al. (2023, JFM). + !> This subroutine computes velocity perturbations for a temporal mixing layer with a hyperbolic tangent mean streamwise + !! velocity profile, using an inverted version of the spectrum-based synthetic turbulence generation method proposed by Guo et + !! al. (2023, JFM). subroutine s_perturb_mixlayer(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(wp), dimension(mixlayer_perturb_nk) :: k, Ek - real(wp), dimension(3, 3) :: Rij, Lmat - real(wp), dimension(3) :: velfluc, sig_tmp, sig, khat, xi - real(wp) :: dk, alpha, Eksum, q, uu0, phi - integer :: i, j, l, r, ierr + real(wp), dimension(mixlayer_perturb_nk) :: k, Ek + real(wp), dimension(3, 3) :: Rij, Lmat + real(wp), dimension(3) :: velfluc, sig_tmp, sig, khat, xi + real(wp) :: dk, alpha, Eksum, q, uu0, phi + integer :: i, j, l, r, ierr ! Initialize parameters dk = 1._wp/mixlayer_perturb_nk @@ -271,9 +244,8 @@ contains do r = 0, n ! Compute prescribed Reynolds stress tensor with about half ! magnitude of its self-similar value - Rij(:, :) = 0._wp - uu0 = patch_icpp(1)%vel(1)**2._wp & - *(1._wp - tanh(y_cc(r)*mixlayer_vel_coef)**2._wp) + Rij(:,:) = 0._wp + uu0 = patch_icpp(1)%vel(1)**2._wp*(1._wp - tanh(y_cc(r)*mixlayer_vel_coef)**2._wp) Rij(1, 1) = 0.05_wp*uu0 Rij(2, 2) = 0.03_wp*uu0 Rij(3, 3) = 0.03_wp*uu0 @@ -324,17 +296,15 @@ contains end do end do end do - end subroutine s_perturb_mixlayer - !> @brief Generates deterministic pseudo-random wave vector, polarization, and phase for a perturbation mode. subroutine s_generate_random_perturbation(khat, xi, phi, ik, yloc) - integer, intent(in) :: ik - real(wp), intent(in) :: yloc + integer, intent(in) :: ik + real(wp), intent(in) :: yloc real(wp), dimension(3), intent(out) :: khat, xi - real(wp), intent(out) :: phi - real(wp) :: theta, eta - integer :: seed, kfac, yfac + real(wp), intent(out) :: phi + real(wp) :: theta, eta + integer :: seed, kfac, yfac kfac = ik*amplifier yfac = nint((sin(yloc) + 1._wp)*amplifier) @@ -349,13 +319,11 @@ contains xi = f_unit_vector(theta, eta) call s_prng(phi, seed) - end subroutine s_generate_random_perturbation - !> @brief Generates a unit vector uniformly distributed on the sphere from two random parameters. function f_unit_vector(theta, eta) result(vec) - real(wp), intent(in) :: theta, eta - real(wp) :: zeta, xi + real(wp), intent(in) :: theta, eta + real(wp) :: zeta, xi real(wp), dimension(3) :: vec xi = 2._wp*pi*theta @@ -363,40 +331,30 @@ contains vec(1) = sin(zeta)*cos(xi) vec(2) = sin(zeta)*sin(xi) vec(3) = cos(zeta) - end function f_unit_vector - - !> This function generates a pseudo-random number between 0 and 1 based on - !! linear congruential generator. + !> This function generates a pseudo-random number between 0 and 1 based on linear congruential generator. subroutine s_prng(var, seed) integer, intent(inout) :: seed - real(wp), intent(out) :: var - integer :: i + real(wp), intent(out) :: var + integer :: i seed = mod(modmul(seed), modulus) var = seed/real(modulus, wp) - end subroutine s_prng - !> @brief Computes a modular multiplication step for the linear congruential pseudo-random number generator. function modmul(a) result(val) integer, intent(in) :: a - integer :: val - real(wp) :: x, y + integer :: val + real(wp) :: x, y x = (multiplier/real(modulus, wp))*a + (increment/real(modulus, wp)) y = nint((x - floor(x))*decimal_trim)/decimal_trim val = nint(y*modulus) - end function modmul - !> @brief Deallocates the temporary primitive variable array used by elliptic smoothing. impure subroutine s_finalize_perturbation_module() - if (elliptic_smoothing) then deallocate (q_prim_temp) end if - end subroutine s_finalize_perturbation_module - end module m_perturbation diff --git a/src/pre_process/m_simplex_noise.fpp b/src/pre_process/m_simplex_noise.fpp index 5dacdda7b6..82f2c87a3a 100644 --- a/src/pre_process/m_simplex_noise.fpp +++ b/src/pre_process/m_simplex_noise.fpp @@ -4,87 +4,60 @@ !> @brief 2D and 3D simplex noise generation for procedural initial condition perturbations module m_simplex_noise - use m_constants use m_precision_select implicit none - private; public :: f_simplex3d, & - f_simplex2d - - integer, parameter :: p_vec(0:511) = [ & - 151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, 53, 194, 233, 7, 225, 140, 36, 103, 30, & - 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, & - 252, 219, 203, 117, 35, 11, 32, 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, & - 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, 231, 83, 111, 229, & - 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, 63, & - 161, 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, & - 159, 86, 164, 100, 109, 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, & - 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, & - 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, & - 129, 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, & - 228, 251, 34, 242, 193, 238, 210, 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, & - 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, 84, 204, 176, 115, 121, 50, 45, 127, & - 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, 66, 215, & - 61, 156, 180, & - 151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, 53, 194, 233, 7, 225, 140, 36, 103, 30, & - 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, & - 252, 219, 203, 117, 35, 11, 32, 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, & - 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, 231, 83, 111, 229, & - 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, 63, & - 161, 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, & - 159, 86, 164, 100, 109, 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, & - 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, & - 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, & - 129, 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, & - 228, 251, 34, 242, 193, 238, 210, 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, & - 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, 84, 204, 176, 115, 121, 50, 45, 127, & - 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, 66, 215, & - 61, 156, 180] - - real(wp), parameter :: grad3(12, 3) = reshape([ & - 1._wp, 1._wp, 0._wp, & - -1._wp, 1._wp, 0._wp, & - 1._wp, -1._wp, 0._wp, & - -1._wp, -1._wp, 0._wp, & - 1._wp, 0._wp, 1._wp, & - -1._wp, 0._wp, 1._wp, & - 1._wp, 0._wp, -1._wp, & - -1._wp, 0._wp, -1._wp, & - 0._wp, 1._wp, 1._wp, & - 0._wp, -1._wp, 1._wp, & - 0._wp, 1._wp, -1._wp, & - 0._wp, -1._wp, -1._wp], shape=[12, 3]) - - real(wp), parameter :: grad2(10, 2) = reshape([ & - 1._wp, 1._wp, & - -1._wp, 1._wp, & - 1._wp, -1._wp, & - -1._wp, -1._wp, & - 1._wp, 0._wp, & - -1._wp, 0._wp, & - 0._wp, 1._wp, & - 0._wp, -1._wp, & - 1._wp, 1._wp, & - -1._wp, 1._wp], shape=[10, 2]) - + private; public :: f_simplex3d, f_simplex2d + + integer, parameter :: p_vec(0:511) = [151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, 53, 194, 233, 7, 225, 140, 36, 103, & + & 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, & + & 252, 219, 203, 117, 35, 11, 32, 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, 171, 168, & + & 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, 231, 83, 111, 229, 122, 60, 211, & + & 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, 63, 161, 1, 216, 80, & + & 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, 159, 86, 164, 100, 109, & + & 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, 147, 118, 126, 255, 82, 85, 212, & + & 207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, 183, 170, 213, 119, 248, 152, 2, 44, & + & 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, 129, 22, 39, 253, 19, 98, 108, 110, 79, 113, & + & 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, 34, 242, 193, 238, 210, 144, 12, 191, & + & 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, & + & 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, & + & 243, 141, 128, 195, 78, 66, 215, 61, 156, 180, 151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, & + & 53, 194, 233, 7, 225, 140, 36, 103, 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, & + & 120, 234, 75, 0, 26, 197, 62, 94, 252, 219, 203, 117, 35, 11, 32, 57, 177, 33, 88, 237, 149, & + & 56, 87, 174, 20, 125, 136, 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, & + & 231, 83, 111, 229, 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, & + & 54, 65, 25, 63, 161, 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, & + & 116, 188, 159, 86, 164, 100, 109, 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, & + & 38, 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, & + & 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, 129, & + & 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, & + & 34, 242, 193, 238, 210, 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, & + & 192, 214, 31, 181, 199, 106, 157, 184, 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, & + & 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, 66, 215, 61, 156, 180] + + real(wp), parameter :: grad3(12, 3) = reshape([1._wp, 1._wp, 0._wp, -1._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, -1._wp, & + & -1._wp, 0._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, 1._wp, 1._wp, 0._wp, -1._wp, -1._wp, 0._wp, -1._wp, 0._wp, 1._wp, & + & 1._wp, 0._wp, -1._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, -1._wp, -1._wp], shape=[12, 3]) + + real(wp), parameter :: grad2(10, 2) = reshape([1._wp, 1._wp, -1._wp, 1._wp, 1._wp, -1._wp, -1._wp, -1._wp, 1._wp, 0._wp, & + & -1._wp, 0._wp, 0._wp, 1._wp, 0._wp, -1._wp, 1._wp, 1._wp, -1._wp, 1._wp], shape=[10, 2]) contains !> @brief Evaluates 3D simplex noise at the given coordinates and returns a value in [-1, 1]. function f_simplex3d(xin, yin, zin) result(n) - real(wp), intent(in) :: xin, yin, zin - real(wp) :: n - real(wp) :: n0, n1, n2, n3 - real(wp) :: f3, g3 - real(wp) :: x0, y0, z0, x1, y1, z1, x2, y2, z2, x3, y3, z3 - integer :: i, j, k, i1, j1, k1, i2, j2, k2 - integer :: ii, jj, kk, gi0, gi1, gi2, gi3 - real(wp) :: s, t, r, t0, t1, t2, t3 - real(wp) :: g(3) - real(wp) :: x, y, z + real(wp) :: n + real(wp) :: n0, n1, n2, n3 + real(wp) :: f3, g3 + real(wp) :: x0, y0, z0, x1, y1, z1, x2, y2, z2, x3, y3, z3 + integer :: i, j, k, i1, j1, k1, i2, j2, k2 + integer :: ii, jj, kk, gi0, gi1, gi2, gi3 + real(wp) :: s, t, r, t0, t1, t2, t3 + real(wp) :: g(3) + real(wp) :: x, y, z f3 = 1._wp/3._wp g3 = 1._wp/6._wp @@ -142,7 +115,7 @@ contains n0 = 0._wp else t0 = t0*t0 - n0 = t0*t0*dot_product(grad3(gi0, :), [x0, y0, z0]) + n0 = t0*t0*dot_product(grad3(gi0,:), [x0, y0, z0]) end if t1 = 0.5_wp - x1*x1 - y1*y1 - z1*z1 @@ -150,7 +123,7 @@ contains n1 = 0._wp else t1 = t1*t1 - n1 = t1*t1*dot_product(grad3(gi1, :), [x1, y1, z1]) + n1 = t1*t1*dot_product(grad3(gi1,:), [x1, y1, z1]) end if t2 = 0.5_wp - x2*x2 - y2*y2 - z2*z2 @@ -158,7 +131,7 @@ contains n2 = 0._wp else t2 = t2*t2 - n2 = t2*t2*dot_product(grad3(gi2, :), [x2, y2, z2]) + n2 = t2*t2*dot_product(grad3(gi2,:), [x2, y2, z2]) end if t3 = 0.5_wp - x3*x3 - y3*y3 - z3*z3 @@ -166,24 +139,21 @@ contains n3 = 0._wp else t3 = t3*t3 - n3 = t3*t3*dot_product(grad3(gi3, :), [x3, y3, z3]) + n3 = t3*t3*dot_product(grad3(gi3,:), [x3, y3, z3]) end if n = 32._wp*(n0 + n1 + n2 + n3) - end function f_simplex3d - !> @brief Evaluates 2D simplex noise at the given coordinates and returns a value in [-1, 1]. function f_simplex2d(xin, yin) result(n) - real(wp), intent(in) :: xin, yin - real(wp) :: n - real(wp), parameter :: F2 = 0.5_wp*(sqrt(3._wp) - 1._wp) - real(wp), parameter :: G2 = (3._wp - sqrt(3._wp))/6._wp - integer :: i, j, ii, jj, gi0, gi1, gi2 - real(wp) :: s, t, x0, y0, x1, y1, x2, y2 - real(wp) :: t0, t1, t2, n0, n1, n2 - integer :: i1, j1 + real(wp) :: n + real(wp), parameter :: F2 = 0.5_wp*(sqrt(3._wp) - 1._wp) + real(wp), parameter :: G2 = (3._wp - sqrt(3._wp))/6._wp + integer :: i, j, ii, jj, gi0, gi1, gi2 + real(wp) :: s, t, x0, y0, x1, y1, x2, y2 + real(wp) :: t0, t1, t2, n0, n1, n2 + integer :: i1, j1 s = (xin + yin)*F2 i = floor(xin + s) @@ -237,17 +207,12 @@ contains end if n = 70._wp*(n0 + n1 + n2) - end function f_simplex2d - !> @brief Computes the dot product of a 2D gradient vector with the given offset coordinates. function dot2(g, x, y) result(dot) - - integer, intent(in) :: g + integer, intent(in) :: g real(wp), intent(in) :: x, y - real(wp) :: dot + real(wp) :: dot dot = grad2(g + 1, 1)*x + grad2(g + 1, 2)*y - - end function - + end function dot2 end module m_simplex_noise diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 64e10ebfec..aaa5aeda92 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -6,7 +6,6 @@ !> @brief Reads and validates user inputs, loads existing grid/IC data, and initializes pre-process modules module m_start_up - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code @@ -57,41 +56,23 @@ module m_start_up implicit none - private; - public :: s_read_input_file, & - s_check_input_file, & - s_read_grid_data_files, & - s_read_ic_data_files, & - s_read_serial_grid_data_files, & - s_read_serial_ic_data_files, & - s_read_parallel_grid_data_files, & - s_read_parallel_ic_data_files, & - s_check_grid_data_files, & - s_initialize_modules, & - s_initialize_mpi_domain, & - s_finalize_modules, & - s_apply_initial_condition, & - s_save_data, s_read_grid + private; + public :: s_read_input_file, s_check_input_file, s_read_grid_data_files, s_read_ic_data_files, s_read_serial_grid_data_files, & + & s_read_serial_ic_data_files, s_read_parallel_grid_data_files, s_read_parallel_ic_data_files, s_check_grid_data_files, & + & s_initialize_modules, s_initialize_mpi_domain, s_finalize_modules, s_apply_initial_condition, s_save_data, s_read_grid abstract interface !> @brief Abstract interface for reading grid data files in serial or parallel. impure subroutine s_read_abstract_grid_data_files - end subroutine s_read_abstract_grid_data_files - !> @brief Abstract interface for reading initial condition data files in serial or parallel. !! @param q_cons_vf Conservative variables impure subroutine s_read_abstract_ic_data_files(q_cons_vf_in) - import :: scalar_field, integer_field, sys_size, pres_field - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf_in - + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in end subroutine s_read_abstract_ic_data_files - end interface character(LEN=path_len + name_len) :: proc_rank_dir !< @@ -103,14 +84,11 @@ module m_start_up procedure(s_read_abstract_grid_data_files), pointer :: s_read_grid_data_files => null() procedure(s_read_abstract_ic_data_files), pointer :: s_read_ic_data_files => null() - contains - !> Reads the configuration file pre_process.inp, in order to - !! populate the parameters in module m_global_parameters.f90 - !! with the user provided inputs + !> Reads the configuration file pre_process.inp, in order to populate the parameters in module m_global_parameters.f90 with the + !! user provided inputs impure subroutine s_read_input_file - character(LEN=name_len) :: file_loc !< !! Generic string used to store the address of a particular file @@ -124,31 +102,17 @@ contains character(len=1000) :: line ! Namelist for all of the parameters to be inputted by the user - namelist /user_inputs/ case_dir, old_grid, old_ic, & - t_step_old, t_step_start, m, n, p, x_domain, y_domain, z_domain, & - stretch_x, stretch_y, stretch_z, a_x, a_y, & - a_z, x_a, y_a, z_a, x_b, y_b, z_b, & - model_eqns, num_fluids, mpp_lim, & - weno_order, bc_x, bc_y, bc_z, num_patches, & - hypoelasticity, mhd, patch_icpp, fluid_pp, bub_pp, & - precision, parallel_io, mixlayer_vel_profile, mixlayer_vel_coef, & - mixlayer_perturb, mixlayer_perturb_nk, mixlayer_perturb_k0, & - pi_fac, perturb_flow, perturb_flow_fluid, perturb_flow_mag, & - perturb_sph, perturb_sph_fluid, fluid_rho, & - cyl_coord, loops_x, loops_y, loops_z, & - rhoref, pref, bubbles_euler, R0ref, nb, & - polytropic, thermal, Ca, Web, Re_inv, & - polydisperse, poly_sigma, qbmm, & - sigR, sigV, dist_type, rhoRV, & - file_per_process, relax, relax_model, & - palpha_eps, ptgalpha_eps, ib, num_ibs, patch_ib, & - sigma, adv_n, cfl_adap_dt, cfl_const_dt, n_start, & - n_start_old, surface_tension, hyperelasticity, pre_stress, & - elliptic_smoothing, elliptic_smoothing_iters, & - viscous, bubbles_lagrange, num_bc_patches, & - patch_bc, Bx0, relativity, cont_damage, igr, igr_order, & - down_sample, recon_type, muscl_order, hyper_cleaning, & - simplex_perturb, simplex_params, fft_wrt + namelist /user_inputs/ case_dir, old_grid, old_ic, t_step_old, t_step_start, m, n, p, x_domain, y_domain, z_domain, & + & stretch_x, stretch_y, stretch_z, a_x, a_y, a_z, x_a, y_a, z_a, x_b, y_b, z_b, model_eqns, num_fluids, mpp_lim, & + & weno_order, bc_x, bc_y, bc_z, num_patches, hypoelasticity, mhd, patch_icpp, fluid_pp, bub_pp, precision, & + & parallel_io, mixlayer_vel_profile, mixlayer_vel_coef, mixlayer_perturb, mixlayer_perturb_nk, mixlayer_perturb_k0, & + & pi_fac, perturb_flow, perturb_flow_fluid, perturb_flow_mag, perturb_sph, perturb_sph_fluid, fluid_rho, cyl_coord, & + & loops_x, loops_y, loops_z, rhoref, pref, bubbles_euler, R0ref, nb, polytropic, thermal, Ca, Web, Re_inv, & + & polydisperse, poly_sigma, qbmm, sigR, sigV, dist_type, rhoRV, file_per_process, relax, relax_model, palpha_eps, & + & ptgalpha_eps, ib, num_ibs, patch_ib, sigma, adv_n, cfl_adap_dt, cfl_const_dt, n_start, n_start_old, & + & surface_tension, hyperelasticity, pre_stress, elliptic_smoothing, elliptic_smoothing_iters, viscous, & + & bubbles_lagrange, num_bc_patches, patch_bc, Bx0, relativity, cont_damage, igr, igr_order, down_sample, recon_type, & + & muscl_order, hyper_cleaning, simplex_perturb, simplex_params, fft_wrt ! Inquiring the status of the pre_process.inp file file_loc = 'pre_process.inp' @@ -157,15 +121,13 @@ contains ! Checking whether the input file is there. If it is, the input file ! is read. If not, the program is terminated. if (file_check) then - open (1, FILE=trim(file_loc), FORM='formatted', & - STATUS='old', ACTION='read') + open (1, FILE=trim(file_loc), form='formatted', STATUS='old', ACTION='read') read (1, NML=user_inputs, iostat=iostatus) if (iostatus /= 0) then backspace (1) read (1, fmt='(A)') line - print *, 'Invalid line in namelist: '//trim(line) - call s_mpi_abort('Invalid line in pre_process.inp. It is '// & - 'likely due to a datatype mismatch. Exiting.') + print *, 'Invalid line in namelist: ' // trim(line) + call s_mpi_abort('Invalid line in pre_process.inp. It is ' // 'likely due to a datatype mismatch. Exiting.') end if close (1) @@ -180,23 +142,16 @@ contains if (cfl_adap_dt .or. cfl_const_dt) cfl_dt = .true. - if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == BC_DIRICHLET) .or. & - num_bc_patches > 0) then + if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == BC_DIRICHLET) .or. num_bc_patches > 0) then bc_io = .true. end if - else call s_mpi_abort('File pre_process.inp is missing. Exiting.') end if - end subroutine s_read_input_file - - !> Checking that the user inputs make sense, i.e. that the - !! individual choices are compatible with the code's options - !! and that the combination of these choices results into a - !! valid configuration for the pre-process + !> Checking that the user inputs make sense, i.e. that the individual choices are compatible with the code's options and that + !! the combination of these choices results into a valid configuration for the pre-process impure subroutine s_check_input_file - character(LEN=len_trim(case_dir)) :: file_loc !< !! Generic string used to store the address of a particular file @@ -206,15 +161,14 @@ contains ! Checking the existence of the case folder case_dir = adjustl(case_dir) - file_loc = trim(case_dir)//'/.' + file_loc = trim(case_dir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then print '(A)', 'WARNING: Ensure that compiler flags/choices in Makefiles match your compiler! ' print '(A)', 'WARNING: Ensure that preprocessor flags are enabled! ' - call s_mpi_abort('Unsupported choice for the value of case_dir.'// & - 'Exiting.') + call s_mpi_abort('Unsupported choice for the value of case_dir.' // 'Exiting.') end if call s_check_inputs_common() @@ -224,14 +178,10 @@ contains call s_check_patches() if (ib) call s_check_ib_patches() - end subroutine s_check_input_file - - !> The goal of this subroutine is to read in any preexisting - !! grid data as well as based on the imported grid, complete - !! the necessary global computational domain parameters. + !> The goal of this subroutine is to read in any preexisting grid data as well as based on the imported grid, complete the + !! necessary global computational domain parameters. impure subroutine s_read_serial_grid_data_files - ! Generic string used to store the address of a particular file character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc @@ -244,36 +194,33 @@ contains ! Setting address of the local processor rank and time-step directory write (proc_rank_dir, '(A,I0)') '/p_all/p', proc_rank - proc_rank_dir = trim(case_dir)//trim(proc_rank_dir) + proc_rank_dir = trim(case_dir) // trim(proc_rank_dir) write (t_step_dir, '(A,I0)') '/', t_step_start - t_step_dir = trim(proc_rank_dir)//trim(t_step_dir) + t_step_dir = trim(proc_rank_dir) // trim(t_step_dir) ! Inquiring as to the existence of the time-step directory - file_loc = trim(t_step_dir)//'/.' + file_loc = trim(t_step_dir) // '/.' call my_inquire(file_loc, dir_check) ! If the time-step directory is missing, the pre-process exits if (dir_check .neqv. .true.) then - call s_mpi_abort('Time-step folder '//trim(t_step_dir)// & - ' is missing. Exiting.') + call s_mpi_abort('Time-step folder ' // trim(t_step_dir) // ' is missing. Exiting.') end if ! Reading the Grid Data File for the x-direction ! Checking whether x_cb.dat exists - file_loc = trim(t_step_dir)//'/x_cb.dat' + file_loc = trim(t_step_dir) // '/x_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) ! If it exists, x_cb.dat is read if (file_check) then - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS='old', ACTION='read') + open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) x_cb(-1:m) close (1) else - call s_mpi_abort('File x_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting.') + call s_mpi_abort('File x_cb.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if ! Computing cell-center locations @@ -290,20 +237,17 @@ contains ! Reading the Grid Data File for the y-direction if (n > 0) then - ! Checking whether y_cb.dat exists - file_loc = trim(t_step_dir)//'/y_cb.dat' + file_loc = trim(t_step_dir) // '/y_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) ! If it exists, y_cb.dat is read if (file_check) then - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS='old', ACTION='read') + open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) y_cb(-1:n) close (1) else - call s_mpi_abort('File y_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting.') + call s_mpi_abort('File y_cb.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if ! Computing cell-center locations @@ -319,20 +263,17 @@ contains ! Reading the Grid Data File for the z-direction if (p > 0) then - ! Checking whether z_cb.dat exists - file_loc = trim(t_step_dir)//'/z_cb.dat' + file_loc = trim(t_step_dir) // '/z_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) ! If it exists, z_cb.dat is read if (file_check) then - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS='old', ACTION='read') + open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) z_cb(-1:p) close (1) else - call s_mpi_abort('File z_cb.dat is missing in '// & - trim(t_step_dir)//'. Exiting.') + call s_mpi_abort('File z_cb.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if ! Computing cell-center locations @@ -345,9 +286,7 @@ contains ! Setting locations of domain bounds z_domain%beg = z_cb(-1) z_domain%end = z_cb(p) - end if - end if ! If only the preexisting grid data files are read in and there will @@ -358,66 +297,43 @@ contains ! condition data are also generated. if (old_ic .neqv. .true.) then call s_delete_directory(trim(proc_rank_dir)) - call s_create_directory(trim(proc_rank_dir)//'/0') + call s_create_directory(trim(proc_rank_dir) // '/0') end if - end subroutine s_read_serial_grid_data_files - - !> Cell-boundary data are checked for consistency by looking - !! at the (non-)uniform cell-width distributions for all the - !! active coordinate directions and making sure that all of - !! the cell-widths are positively valued + !> Cell-boundary data are checked for consistency by looking at the (non-)uniform cell-width distributions for all the active + !! coordinate directions and making sure that all of the cell-widths are positively valued impure subroutine s_check_grid_data_files - ! Cell-boundary Data Consistency Check in x-direction if (any(x_cb(0:m) - x_cb(-1:m - 1) <= 0._wp)) then - call s_mpi_abort('x_cb.dat in '//trim(t_step_dir)// & - ' contains non-positive cell-spacings. Exiting.') + call s_mpi_abort('x_cb.dat in ' // trim(t_step_dir) // ' contains non-positive cell-spacings. Exiting.') end if ! Cell-boundary Data Consistency Check in y-direction if (n > 0) then - if (any(y_cb(0:n) - y_cb(-1:n - 1) <= 0._wp)) then - call s_mpi_abort('y_cb.dat in '//trim(t_step_dir)// & - ' contains non-positive cell-spacings. '// & - 'Exiting.') + call s_mpi_abort('y_cb.dat in ' // trim(t_step_dir) // ' contains non-positive cell-spacings. ' // 'Exiting.') end if ! Cell-boundary Data Consistency Check in z-direction if (p > 0) then - if (any(z_cb(0:p) - z_cb(-1:p - 1) <= 0._wp)) then - call s_mpi_abort('z_cb.dat in '//trim(t_step_dir)// & - ' contains non-positive cell-spacings'// & - ' .Exiting.') + call s_mpi_abort('z_cb.dat in ' // trim(t_step_dir) // ' contains non-positive cell-spacings' // ' .Exiting.') end if - end if - end if - end subroutine s_check_grid_data_files - - !> The goal of this subroutine is to read in any preexisting - !! initial condition data files so that they may be used by - !! the pre-process as a starting point in the creation of an - !! all new initial condition. + !> The goal of this subroutine is to read in any preexisting initial condition data files so that they may be used by the + !! pre-process as a starting point in the creation of an all new initial condition. !! @param q_cons_vf_in Conservative variables impure subroutine s_read_serial_ic_data_files(q_cons_vf_in) - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf_in - - character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc !< + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in + character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc !< ! Generic string used to store the address of a particular file - character(LEN= & - int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< !! Used to store the variable position, in character form, of the !! currently manipulated conservative variable file @@ -429,52 +345,41 @@ contains ! Reading the Conservative Variables Data Files do i = 1, sys_size - ! Checking whether data file associated with variable position ! of the currently manipulated conservative variable exists write (file_num, '(I0)') i - file_loc = trim(t_step_dir)//'/q_cons_vf'// & - trim(file_num)//'.dat' + file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) ! If it exists, the data file is read if (file_check) then - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS='old', ACTION='read') + open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) q_cons_vf_in(i)%sf close (1) else - call s_mpi_abort('File q_cons_vf'//trim(file_num)// & - '.dat is missing in '//trim(t_step_dir)// & - '. Exiting.') + call s_mpi_abort('File q_cons_vf' // trim(file_num) // '.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if - end do - !Read bubble variables pb and mv for non-polytropic qbmm + ! Read bubble variables pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode ! Checking whether data file associated with variable position ! of the currently manipulated bubble variable exists write (file_num, '(I0)') sys_size + r + (i - 1)*nnode - file_loc = trim(t_step_dir)//'/pb'// & - trim(file_num)//'.dat' + file_loc = trim(t_step_dir) // '/pb' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) ! If it exists, the data file is read if (file_check) then - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS='old', ACTION='read') - read (1) pb%sf(:, :, :, r, i) + open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') + read (1) pb%sf(:,:,:, r, i) close (1) else - call s_mpi_abort('File pb'//trim(file_num)// & - '.dat is missing in '//trim(t_step_dir)// & - '. Exiting.') + call s_mpi_abort('File pb' // trim(file_num) // '.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if end do - end do do i = 1, nb @@ -482,23 +387,18 @@ contains ! Checking whether data file associated with variable position ! of the currently manipulated bubble variable exists write (file_num, '(I0)') sys_size + r + (i - 1)*nnode - file_loc = trim(t_step_dir)//'/mv'// & - trim(file_num)//'.dat' + file_loc = trim(t_step_dir) // '/mv' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) ! If it exists, the data file is read if (file_check) then - open (1, FILE=trim(file_loc), FORM='unformatted', & - STATUS='old', ACTION='read') - read (1) mv%sf(:, :, :, r, i) + open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') + read (1) mv%sf(:,:,:, r, i) close (1) else - call s_mpi_abort('File mv'//trim(file_num)// & - '.dat is missing in '//trim(t_step_dir)// & - '. Exiting.') + call s_mpi_abort('File mv' // trim(file_num) // '.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if end do - end do end if @@ -508,32 +408,25 @@ contains ! In addition, the time-step folder that will contain the new grid ! and initial condition data are also generated. call s_delete_directory(trim(proc_rank_dir)) - call s_create_directory(trim(proc_rank_dir)//'/0') - + call s_create_directory(trim(proc_rank_dir) // '/0') end subroutine s_read_serial_ic_data_files - - !> Cell-boundary data are checked for consistency by looking - !! at the (non-)uniform cell-width distributions for all the - !! active coordinate directions and making sure that all of - !! the cell-widths are positively valued + !> Cell-boundary data are checked for consistency by looking at the (non-)uniform cell-width distributions for all the active + !! coordinate directions and making sure that all of the cell-widths are positively valued impure subroutine s_read_parallel_grid_data_files - #ifdef MFC_MPI - real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb - - integer :: ifile, ierr, data_size - integer, dimension(MPI_STATUS_SIZE) :: status - + real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb + integer :: ifile, ierr, data_size + integer, dimension(MPI_STATUS_SIZE) :: status character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist + logical :: file_exist allocate (x_cb_glb(-1:m_glb)) allocate (y_cb_glb(-1:n_glb)) allocate (z_cb_glb(-1:p_glb)) ! Read in cell boundary locations in x-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'x_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'x_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -542,7 +435,7 @@ contains call MPI_FILE_READ_ALL(ifile, x_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting. ') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting. ') end if ! Assigning local cell boundary locations @@ -558,7 +451,7 @@ contains if (n > 0) then ! Read in cell boundary locations in y-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'y_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'y_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -567,7 +460,7 @@ contains call MPI_FILE_READ_ALL(ifile, y_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting. ') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting. ') end if ! Assigning local cell boundary locations @@ -583,7 +476,7 @@ contains if (p > 0) then ! Read in cell boundary locations in z-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'z_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'z_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -592,7 +485,7 @@ contains call MPI_FILE_READ_ALL(ifile, z_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting. ') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting. ') end if ! Assigning local cell boundary locations @@ -605,41 +498,30 @@ contains ! Setting locations of domain bounds z_domain%beg = z_cb(-1) z_domain%end = z_cb(p) - end if end if deallocate (x_cb_glb, y_cb_glb, z_cb_glb) - #endif - end subroutine s_read_parallel_grid_data_files - - !> The goal of this subroutine is to read in any preexisting - !! initial condition data files so that they may be used by - !! the pre-process as a starting point in the creation of an - !! all new initial condition. + !> The goal of this subroutine is to read in any preexisting initial condition data files so that they may be used by the + !! pre-process as a starting point in the creation of an all new initial condition. !! @param q_cons_vf_in Conservative variables impure subroutine s_read_parallel_ic_data_files(q_cons_vf_in) - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf_in + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in #ifdef MFC_MPI - integer :: ifile, ierr, data_size - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer(KIND=MPI_OFFSET_KIND) :: m_MOK, n_MOK, p_MOK - integer(KIND=MPI_OFFSET_KIND) :: WP_MOK, var_MOK, str_MOK - integer(KIND=MPI_OFFSET_KIND) :: NVARS_MOK - integer(KIND=MPI_OFFSET_KIND) :: MOK - + integer :: ifile, ierr, data_size + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer(KIND=MPI_OFFSET_KIND) :: m_MOK, n_MOK, p_MOK + integer(KIND=MPI_OFFSET_KIND) :: WP_MOK, var_MOK, str_MOK + integer(KIND=MPI_OFFSET_KIND) :: NVARS_MOK + integer(KIND=MPI_OFFSET_KIND) :: MOK character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist - - integer :: i + logical :: file_exist + integer :: i ! Open the file to read if (cfl_adap_dt) then @@ -647,7 +529,7 @@ contains else write (file_loc, '(I0,A)') t_step_start, '.dat' end if - file_loc = trim(restart_dir)//trim(mpiiofs)//trim(file_loc) + file_loc = trim(restart_dir) // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -674,10 +556,8 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - mpi_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, mpi_p, status, ierr) end do if (qbmm .and. .not. polytropic) then @@ -687,27 +567,21 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, & - mpi_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size, mpi_p, status, ierr) end do end if call s_mpi_barrier() call MPI_FILE_CLOSE(ifile, ierr) - else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting. ') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting. ') end if call s_mpi_barrier() - #endif - end subroutine s_read_parallel_ic_data_files - !> @brief Initializes all pre-process modules, allocates data structures, and sets I/O procedure pointers. impure subroutine s_initialize_modules ! Computation of parameters, allocation procedures, and/or any other tasks @@ -742,12 +616,9 @@ contains s_read_ic_data_files => s_read_parallel_ic_data_files s_write_data_files => s_write_parallel_data_files end if - end subroutine s_initialize_modules - !> @brief Reads an existing grid from data files or generates a new grid from user inputs. impure subroutine s_read_grid() - if (old_grid) then call s_read_grid_data_files() call s_check_grid_data_files() @@ -761,16 +632,12 @@ contains call s_check_grid_data_files() end if end if - end subroutine s_read_grid - !> @brief Generates or reads the initial condition, applies relaxation if needed, and writes output data files. impure subroutine s_apply_initial_condition(start, finish) - real(wp), intent(inout) :: start, finish - - integer :: j, k, l - real(wp) :: r2 + integer :: j, k, l + real(wp) :: r2 ! Setting up the grid and the initial condition. If the grid is read in from ! preexisting grid data files, it is checked for consistency. If the grid is @@ -807,7 +674,7 @@ contains if (relax) then if (proc_rank == 0) then print *, 'initial condition might have been altered due to enforcement of & -& pTg-equilibrium (relax = "T" activated)' + & pTg - equilibrium (relax="T" activated)' end if call s_infinite_relaxation_k(q_cons_vf) @@ -817,13 +684,11 @@ contains call cpu_time(finish) end subroutine s_apply_initial_condition - !> @brief Gathers processor timing data and writes elapsed wall-clock time to a summary file. impure subroutine s_save_data(proc_time, time_avg, time_final, file_exists) - real(wp), dimension(:), intent(inout) :: proc_time - real(wp), intent(inout) :: time_avg, time_final - logical, intent(inout) :: file_exists + real(wp), intent(inout) :: time_avg, time_final + logical, intent(inout) :: file_exists call s_mpi_barrier() @@ -852,7 +717,6 @@ contains end if end if end subroutine s_save_data - !> @brief Initializes MPI, reads and validates user inputs on rank 0, and decomposes the computational domain. impure subroutine s_initialize_mpi_domain ! Initialization of the MPI environment @@ -879,7 +743,6 @@ contains call s_initialize_parallel_io() call s_mpi_decompose_computational_domain() end subroutine s_initialize_mpi_domain - !> @brief Finalizes all pre-process modules, deallocates resources, and shuts down MPI. impure subroutine s_finalize_modules ! Disassociate pointers for serial and parallel I/O @@ -902,5 +765,4 @@ contains ! Finalization of the MPI environment call s_mpi_finalize() end subroutine s_finalize_modules - end module m_start_up diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index 9197eecf8f..c2937ce0ff 100644 --- a/src/pre_process/p_main.f90 +++ b/src/pre_process/p_main.f90 @@ -2,18 +2,16 @@ !! @file !! @brief Contains program p_main -!> @brief This program takes care of setting up the initial condition and -!! grid data for the multicomponent flow code. +!> @brief This program takes care of setting up the initial condition and grid data for the multicomponent flow code. program p_main - use m_global_parameters !< Global parameters for the code use m_start_up implicit none - logical :: file_exists - real(wp) :: start, finish, time_avg, time_final + logical :: file_exists + real(wp) :: start, finish, time_avg, time_final real(wp), allocatable, dimension(:) :: proc_time call random_seed() @@ -37,5 +35,4 @@ program p_main deallocate (proc_time) call s_finalize_modules() - end program p_main diff --git a/src/simulation/include/inline_capillary.fpp b/src/simulation/include/inline_capillary.fpp index 89e1aabaec..ba62d99740 100644 --- a/src/simulation/include/inline_capillary.fpp +++ b/src/simulation/include/inline_capillary.fpp @@ -1,5 +1,4 @@ #:def compute_capillary_stress_tensor() - Omega(1, 1) = -sigma*(w2*w2 + w3*w3)/normW #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 Omega(2, 1) = sigma*w1*w2/normW @@ -18,7 +17,5 @@ Omega(3, 3) = -sigma*(w1*w1 + w2*w2)/normW #:endif - end if - #:enddef compute_capillary_stress_tensor diff --git a/src/simulation/include/inline_riemann.fpp b/src/simulation/include/inline_riemann.fpp index d8d0cc87c7..aae4015292 100644 --- a/src/simulation/include/inline_riemann.fpp +++ b/src/simulation/include/inline_riemann.fpp @@ -9,32 +9,25 @@ 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) - #:enddef arithmetic_avg #:def roe_avg() - rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels - vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2._wp/ & - (sqrt(rho_L) + sqrt(rho_R))**2._wp + vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2._wp/(sqrt(rho_L) + sqrt(rho_R))**2._wp end do - H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & - (sqrt(rho_L) + sqrt(rho_R)) + H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/(sqrt(rho_L) + sqrt(rho_R)) - gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & - (sqrt(rho_L) + sqrt(rho_R)) + gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/(sqrt(rho_L) + sqrt(rho_R)) - vel_avg_rms = (sqrt(rho_L)*vel_L(1) + sqrt(rho_R)*vel_R(1))**2._wp/ & - (sqrt(rho_L) + sqrt(rho_R))**2._wp + vel_avg_rms = (sqrt(rho_L)*vel_L(1) + sqrt(rho_R)*vel_R(1))**2._wp/(sqrt(rho_L) + sqrt(rho_R))**2._wp - qv_avg = (sqrt(rho_L)*qv_L + sqrt(rho_R)*qv_R)/ & - (sqrt(rho_L) + sqrt(rho_R)) + qv_avg = (sqrt(rho_L)*qv_L + sqrt(rho_R)*qv_R)/(sqrt(rho_L) + sqrt(rho_R)) if (chemistry) then eps = 0.001_wp @@ -57,7 +50,8 @@ if (abs(T_L - T_R) < eps) then ! Case when T_L and T_R are very close Cp_avg = sum(Yi_avg(:)*(0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights_nonparameter(:)) - Cv_avg = sum(Yi_avg(:)*((0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights_nonparameter(:) - gas_constant/molecular_weights_nonparameter(:))) + Cv_avg = sum(Yi_avg(:)*((0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights_nonparameter(:) & + & - gas_constant/molecular_weights_nonparameter(:))) else ! Normal calculation when T_L and T_R are sufficiently different Cp_avg = sum(Yi_avg(:)*(h_iR(:) - h_iL(:))/(T_R - T_L)) @@ -65,13 +59,15 @@ end if gamma_avg = Cp_avg/Cv_avg - Phi_avg(:) = (gamma_avg - 1._wp)*(vel_avg_rms/2.0_wp - h_avg_2(:)) + gamma_avg*gas_constant/molecular_weights_nonparameter(:)*T_avg + Phi_avg(:) = (gamma_avg - 1._wp)*(vel_avg_rms/2.0_wp - h_avg_2(:)) & + & + gamma_avg*gas_constant/molecular_weights_nonparameter(:)*T_avg c_sum_Yi_Phi = sum(Yi_avg(:)*Phi_avg(:)) #:else if (abs(T_L - T_R) < eps) then ! Case when T_L and T_R are very close Cp_avg = sum(Yi_avg(:)*(0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights(:)) - Cv_avg = sum(Yi_avg(:)*((0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights(:) - gas_constant/molecular_weights(:))) + Cv_avg = sum(Yi_avg(:)*((0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights(:) & + & - gas_constant/molecular_weights(:))) else ! Normal calculation when T_L and T_R are sufficiently different Cp_avg = sum(Yi_avg(:)*(h_iR(:) - h_iL(:))/(T_R - T_L)) @@ -82,13 +78,10 @@ Phi_avg(:) = (gamma_avg - 1._wp)*(vel_avg_rms/2.0_wp - h_avg_2(:)) + gamma_avg*gas_constant/molecular_weights(:)*T_avg c_sum_Yi_Phi = sum(Yi_avg(:)*Phi_avg(:)) #:endif - end if - #:enddef roe_avg #:def compute_average_state() - if (avg_state == 1) then @:roe_avg() end if @@ -96,29 +89,23 @@ if (avg_state == 2) then @:arithmetic_avg() end if - #:enddef compute_average_state #:def compute_low_Mach_correction() - if (riemann_solver == 1 .or. riemann_solver == 5) then - zcoef = min(1._wp, max(vel_L_rms**5.e-1_wp/c_L, vel_R_rms**5.e-1_wp/c_R)) pcorr = 0._wp if (low_Mach == 1) then pcorr = -(s_P - s_M)*(rho_L + rho_R)/8._wp*(zcoef - 1._wp) end if - else if (riemann_solver == 2) then zcoef = min(1._wp, max(vel_L_rms**5.e-1_wp/c_L, vel_R_rms**5.e-1_wp/c_R)) pcorr = 0._wp if (low_Mach == 1) then - pcorr = rho_L*rho_R* & - (s_L - vel_L(dir_idx(1)))*(s_R - vel_R(dir_idx(1)))*(vel_R(dir_idx(1)) - vel_L(dir_idx(1)))/ & - (rho_R*(s_R - vel_R(dir_idx(1))) - rho_L*(s_L - vel_L(dir_idx(1))))* & - (zcoef - 1._wp) + pcorr = rho_L*rho_R*(s_L - vel_L(dir_idx(1)))*(s_R - vel_R(dir_idx(1)))*(vel_R(dir_idx(1)) - vel_L(dir_idx(1))) & + & /(rho_R*(s_R - vel_R(dir_idx(1))) - rho_L*(s_L - vel_L(dir_idx(1))))*(zcoef - 1._wp) else if (low_Mach == 2) then vel_L_tmp = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + zcoef*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) vel_R_tmp = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + zcoef*(vel_R(dir_idx(1)) - vel_L(dir_idx(1)))) @@ -126,5 +113,4 @@ vel_R(dir_idx(1)) = vel_R_tmp end if end if - #:enddef compute_low_Mach_correction diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 5b021fecbf..6e2f4d821f 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -6,7 +6,6 @@ !> @brief Applies acoustic pressure source terms including focused, planar, and broadband transducers module m_acoustic_src - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -23,51 +22,55 @@ module m_acoustic_src private; public :: s_initialize_acoustic_src, s_precalculate_acoustic_spatial_sources, s_acoustic_src_calculations integer, allocatable, dimension(:) :: pulse, support - $:GPU_DECLARE(create='[pulse,support]') + $:GPU_DECLARE(create='[pulse, support]') logical, allocatable, dimension(:) :: dipole $:GPU_DECLARE(create='[dipole]') - real(wp), allocatable, target, dimension(:, :) :: loc_acoustic + real(wp), allocatable, target, dimension(:,:) :: loc_acoustic $:GPU_DECLARE(create='[loc_acoustic]') real(wp), allocatable, dimension(:) :: mag, length, height, wavelength, frequency real(wp), allocatable, dimension(:) :: gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay - $:GPU_DECLARE(create='[mag,length,height,wavelength,frequency]') - $:GPU_DECLARE(create='[gauss_sigma_dist,gauss_sigma_time,npulse,dir,delay]') + $:GPU_DECLARE(create='[mag, length, height, wavelength, frequency]') + $:GPU_DECLARE(create='[gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay]') real(wp), allocatable, dimension(:) :: foc_length, aperture - $:GPU_DECLARE(create='[foc_length,aperture]') + $:GPU_DECLARE(create='[foc_length, aperture]') real(wp), allocatable, dimension(:) :: element_spacing_angle, element_polygon_ratio, rotate_angle - $:GPU_DECLARE(create='[element_spacing_angle,element_polygon_ratio,rotate_angle]') + $:GPU_DECLARE(create='[element_spacing_angle, element_polygon_ratio, rotate_angle]') real(wp), allocatable, dimension(:) :: bb_bandwidth, bb_lowest_freq - $:GPU_DECLARE(create='[bb_bandwidth,bb_lowest_freq]') + $:GPU_DECLARE(create='[bb_bandwidth, bb_lowest_freq]') integer, allocatable, dimension(:) :: num_elements, element_on, bb_num_freq - $:GPU_DECLARE(create='[num_elements,element_on,bb_num_freq]') + $:GPU_DECLARE(create='[num_elements, element_on, bb_num_freq]') !> @name Acoustic source terms !> @{ - real(wp), allocatable, dimension(:, :, :) :: mass_src, e_src - real(wp), allocatable, dimension(:, :, :, :) :: mom_src + real(wp), allocatable, dimension(:,:,:) :: mass_src, e_src + real(wp), allocatable, dimension(:,:,:,:) :: mom_src !> @} - $:GPU_DECLARE(create='[mass_src,e_src,mom_src]') + $:GPU_DECLARE(create='[mass_src, e_src, mom_src]') integer, dimension(:), allocatable :: source_spatials_num_points !< Number of non-zero source grid points for each source $:GPU_DECLARE(create='[source_spatials_num_points]') type(source_spatial_type), dimension(:), allocatable :: source_spatials !< Data of non-zero source grid points for each source $:GPU_DECLARE(create='[source_spatials]') - contains !> This subroutine initializes the acoustic source module impure subroutine s_initialize_acoustic_src integer :: i, j !< generic loop variables - @:ALLOCATE(loc_acoustic(1:3, 1:num_source), mag(1:num_source), dipole(1:num_source), support(1:num_source), length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), aperture(1:num_source), npulse(1:num_source), pulse(1:num_source), dir(1:num_source), delay(1:num_source), element_polygon_ratio(1:num_source), rotate_angle(1:num_source), element_spacing_angle(1:num_source), num_elements(1:num_source), element_on(1:num_source), bb_num_freq(1:num_source), bb_bandwidth(1:num_source), bb_lowest_freq(1:num_source)) + @:ALLOCATE(loc_acoustic(1:3, 1:num_source), mag(1:num_source), dipole(1:num_source), support(1:num_source), & + & length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), & + & gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), & + & aperture(1:num_source), npulse(1:num_source), pulse(1:num_source), dir(1:num_source), delay(1:num_source), & + & element_polygon_ratio(1:num_source), rotate_angle(1:num_source), element_spacing_angle(1:num_source), & + & num_elements(1:num_source), element_on(1:num_source), bb_num_freq(1:num_source), bb_bandwidth(1:num_source), bb_lowest_freq(1:num_source)) do i = 1, num_source do j = 1, 3 @@ -111,27 +114,21 @@ contains end if end do $:GPU_UPDATE(device='[loc_acoustic,mag,dipole,support,length, & - & height,wavelength,frequency,gauss_sigma_dist, & - & gauss_sigma_time,foc_length,aperture,npulse,pulse, & - & dir,delay,element_polygon_ratio,rotate_angle, & - & element_spacing_angle,num_elements,element_on, & - & bb_num_freq,bb_bandwidth,bb_lowest_freq]') + & height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, & + & element_polygon_ratio, rotate_angle, element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, & + & bb_lowest_freq]') @:ALLOCATE(mass_src(0:m, 0:n, 0:p)) @:ALLOCATE(mom_src(1:num_vels, 0:m, 0:n, 0:p)) @:ALLOCATE(E_src(0:m, 0:n, 0:p)) - end subroutine s_initialize_acoustic_src - !> This subroutine updates the rhs by computing the mass, mom, energy sources !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables !! @param rhs_vf rhs variables impure subroutine s_acoustic_src_calculations(q_cons_vf, q_prim_vf, rhs_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Conservative variables type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive variables - type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -139,28 +136,25 @@ contains #:else real(wp), dimension(num_fluids) :: myalpha, myalpha_rho #:endif - real(wp) :: myRho, B_tait - real(wp) :: sim_time, c, small_gamma - real(wp) :: frequency_local, gauss_sigma_time_local - real(wp) :: mass_src_diff, mom_src_diff - real(wp) :: source_temporal - real(wp) :: period_BB !< period of each sine wave in broadband source - real(wp) :: sl_BB !< spectral level at each frequency - real(wp) :: ffre_BB !< source term corresponding to each frequency - real(wp) :: sum_BB !< total source term for the broadband wave + real(wp) :: myRho, B_tait + real(wp) :: sim_time, c, small_gamma + real(wp) :: frequency_local, gauss_sigma_time_local + real(wp) :: mass_src_diff, mom_src_diff + real(wp) :: source_temporal + real(wp) :: period_BB !< period of each sine wave in broadband source + real(wp) :: sl_BB !< spectral level at each frequency + real(wp) :: ffre_BB !< source term corresponding to each frequency + real(wp) :: sum_BB !< total source term for the broadband wave real(wp), allocatable, dimension(:) :: phi_rn !< random phase shift for each frequency - - integer :: i, j, k, l, q !< generic loop variables - integer :: ai !< acoustic source index - integer :: num_points - - logical :: freq_conv_flag, gauss_conv_flag - - integer, parameter :: mass_label = 1, mom_label = 2 + integer :: i, j, k, l, q !< generic loop variables + integer :: ai !< acoustic source index + integer :: num_points + logical :: freq_conv_flag, gauss_conv_flag + integer, parameter :: mass_label = 1, mom_label = 2 sim_time = mytime ! Accumulated time, correct under adaptive dt - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m @@ -178,7 +172,6 @@ contains do ai = 1, num_source ! Skip if the pulse has not started yet for sine and square waves if (.not. (sim_time < delay(ai) .and. (pulse(ai) == 1 .or. pulse(ai) == 3))) then - ! Decide if frequency need to be converted from wavelength freq_conv_flag = f_is_default(frequency(ai)) gauss_conv_flag = f_is_default(gauss_sigma_time(ai)) @@ -214,7 +207,9 @@ contains deallocate (phi_rn) - $:GPU_PARALLEL_LOOP(private='[myalpha,myalpha_rho, myRho, B_tait,c, small_gamma, frequency_local, gauss_sigma_time_local, mass_src_diff, mom_src_diff, source_temporal, j, k, l, q ]', copyin = '[sum_BB, freq_conv_flag, gauss_conv_flag, sim_time]') + $:GPU_PARALLEL_LOOP(private='[myalpha, myalpha_rho, myRho, B_tait, c, small_gamma, frequency_local, & + & gauss_sigma_time_local, mass_src_diff, mom_src_diff, source_temporal, j, k, l, q]', & + & copyin = '[sum_BB, freq_conv_flag, gauss_conv_flag, sim_time]') do i = 1, num_points j = source_spatials(ai)%coord(1, i) k = source_spatials(ai)%coord(2, i) @@ -263,7 +258,8 @@ contains if (pulse(ai) == 2) gauss_sigma_time_local = f_gauss_sigma_time_local(gauss_conv_flag, ai, c) ! Update momentum source term - call s_source_temporal(sim_time, c, ai, mom_label, frequency_local, gauss_sigma_time_local, source_temporal, sum_BB) + call s_source_temporal(sim_time, c, ai, mom_label, frequency_local, gauss_sigma_time_local, source_temporal, & + & sum_BB) mom_src_diff = source_temporal*source_spatials(ai)%val(i) if (dipole(ai)) then ! Double amplitude & No momentum source term (only works for Planar) @@ -274,8 +270,7 @@ contains if (n == 0) then ! 1D mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*sign(1._wp, dir(ai)) ! Left or right-going wave - - elseif (p == 0) then ! 2D + else if (p == 0) then ! 2D if (support(ai) < 5) then ! Planar mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(dir(ai)) mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*sin(dir(ai)) @@ -283,7 +278,6 @@ contains mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(source_spatials(ai)%angle(i)) mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*sin(source_spatials(ai)%angle(i)) end if - else ! 3D if (support(ai) < 5) then ! Planar mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(dir(ai)) @@ -299,8 +293,10 @@ contains if (support(ai) < 5) then ! Planar mass_src_diff = mom_src_diff/c else ! Spherical or cylindrical support - ! Mass source term must be calculated differently using a correction term for spherical and cylindrical support - call s_source_temporal(sim_time, c, ai, mass_label, frequency_local, gauss_sigma_time_local, source_temporal, sum_BB) + ! Mass source term must be calculated differently using a correction term for spherical and cylindrical + ! support + call s_source_temporal(sim_time, c, ai, mass_label, frequency_local, gauss_sigma_time_local, & + & source_temporal, sum_BB) mass_src_diff = source_temporal*source_spatials(ai)%val(i) end if mass_src(j, k, l) = mass_src(j, k, l) + mass_src_diff @@ -309,14 +305,13 @@ contains if (model_eqns /= 4) then E_src(j, k, l) = E_src(j, k, l) + mass_src_diff*c**2._wp/(small_gamma - 1._wp) end if - end do $:END_GPU_PARALLEL_LOOP() end if end do ! Update the rhs variables - $:GPU_PARALLEL_LOOP(private='[j,k,l]',collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]',collapse=3) do l = 0, p do k = 0, n do j = 0, m @@ -334,7 +329,6 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_acoustic_src_calculations - !> This subroutine gives the temporally varying amplitude of the pulse !! @param sim_time Simulation time !! @param c Sound speed @@ -346,23 +340,22 @@ contains !! @param sum_bb Sum of basis functions elemental subroutine s_source_temporal(sim_time, c, ai, term_index, frequency_local, gauss_sigma_time_local, source, sum_BB) $:GPU_ROUTINE(parallelism='[seq]') - integer, intent(in) :: ai, term_index - real(wp), intent(in) :: sim_time, c, sum_BB - real(wp), intent(in) :: frequency_local, gauss_sigma_time_local + integer, intent(in) :: ai, term_index + real(wp), intent(in) :: sim_time, c, sum_BB + real(wp), intent(in) :: frequency_local, gauss_sigma_time_local real(wp), intent(out) :: source - - real(wp) :: omega ! angular frequency - real(wp) :: sine_wave ! sine function for square wave - real(wp) :: foc_length_factor ! Scale amplitude with radius for spherical support + real(wp) :: omega ! angular frequency + real(wp) :: sine_wave ! sine function for square wave + real(wp) :: foc_length_factor ! Scale amplitude with radius for spherical support ! i.e. Spherical support -> 1/r scaling; Cylindrical support -> 1/sqrt(r) [empirical correction: ^-0.5 -> ^-0.85] integer, parameter :: mass_label = 1 if (n == 0) then foc_length_factor = 1._wp - elseif (p == 0 .and. (.not. cyl_coord)) then ! 2D axisymmetric case is physically 3D + else if (p == 0 .and. (.not. cyl_coord)) then ! 2D axisymmetric case is physically 3D foc_length_factor = foc_length(ai)**(-0.85_wp); ! Empirical correction else - foc_length_factor = 1/foc_length(ai); + foc_length_factor = 1/foc_length(ai); end if source = 0._wp @@ -376,17 +369,14 @@ contains if (term_index == mass_label) then source = source/c + foc_length_factor*mag(ai)*(cos((sim_time - delay(ai))*omega) - 1._wp)/omega end if - - elseif (pulse(ai) == 2) then ! Gaussian pulse + else if (pulse(ai) == 2) then ! Gaussian pulse source = mag(ai)*exp(-0.5_wp*((sim_time - delay(ai))**2._wp)/(gauss_sigma_time_local**2._wp)) if (term_index == mass_label) then - source = source/c - & - foc_length_factor*mag(ai)*sqrt(pi/2)*gauss_sigma_time_local* & - (erf((sim_time - delay(ai))/(sqrt(2._wp)*gauss_sigma_time_local)) + 1) + source = source/c - foc_length_factor*mag(ai)*sqrt(pi/2)*gauss_sigma_time_local*(erf((sim_time - delay(ai)) & + & /(sqrt(2._wp)*gauss_sigma_time_local)) + 1) end if - - elseif (pulse(ai) == 3) then ! Square wave + else if (pulse(ai) == 3) then ! Square wave if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return omega = 2._wp*pi*frequency_local @@ -397,23 +387,21 @@ contains if (abs(sine_wave) < 1.e-2_wp) then source = mag(ai)*sine_wave*1.e2_wp end if - - elseif (pulse(ai) == 4) then ! Broadband wave + else if (pulse(ai) == 4) then ! Broadband wave source = sum_BB end if end subroutine s_source_temporal - !> This subroutine identifies and precalculates the non-zero acoustic spatial sources before time-stepping impure subroutine s_precalculate_acoustic_spatial_sources - integer :: j, k, l, ai - integer :: count - integer :: dim - real(wp) :: source_spatial, angle, xyz_to_r_ratios(3) + integer :: j, k, l, ai + integer :: count + integer :: dim + real(wp) :: source_spatial, angle, xyz_to_r_ratios(3) real(wp), parameter :: threshold = 1.e-10_wp if (n == 0) then dim = 1 - elseif (p == 0) then + else if (p == 0) then dim = 2 else dim = 3 @@ -479,18 +467,15 @@ contains $:GPU_UPDATE(device='[source_spatials(ai)%xyz_to_r_ratios]') end if end if - end do #ifdef MFC_DEBUG do ai = 1, num_source write (*, '(A,I2,A,I8,A)') 'Acoustic source ', ai, ' has ', source_spatials_num_points(ai), & - ' grid points with non-zero source term' + & ' grid points with non-zero source term' end do #endif - end subroutine s_precalculate_acoustic_spatial_sources - !> This subroutine gives the spatial support of the acoustic source !! @param j x-index !! @param k y-index @@ -501,16 +486,15 @@ contains !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial(j, k, l, loc, ai, source, angle, xyz_to_r_ratios) - integer, intent(in) :: j, k, l, ai + integer, intent(in) :: j, k, l, ai real(wp), dimension(3), intent(in) :: loc - real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) - - real(wp) :: sig, r(3) + real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) + real(wp) :: sig, r(3) ! Calculate sig spatial support width if (n == 0) then sig = dx(j) - elseif (p == 0) then + else if (p == 0) then sig = maxval((/dx(j), dy(k)/)) else sig = maxval((/dx(j), dy(k), dz(l)/)) @@ -524,41 +508,38 @@ contains if (any(support(ai) == (/1, 2, 3, 4/))) then call s_source_spatial_planar(ai, sig, r, source) - elseif (any(support(ai) == (/5, 6, 7/))) then + else if (any(support(ai) == (/5, 6, 7/))) then call s_source_spatial_transducer(ai, sig, r, source, angle, xyz_to_r_ratios) - elseif (any(support(ai) == (/9, 10, 11/))) then + else if (any(support(ai) == (/9, 10, 11/))) then call s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios) end if end subroutine s_source_spatial - !> This subroutine calculates the spatial support for planar acoustic sources in 1D, 2D, and 3D !! @param ai Acoustic source index !! @param sig Sigma value for the Gaussian distribution !! @param r Displacement from source to current point !! @param source Source term amplitude subroutine s_source_spatial_planar(ai, sig, r, source) - integer, intent(in) :: ai - real(wp), intent(in) :: sig, r(3) + integer, intent(in) :: ai + real(wp), intent(in) :: sig, r(3) real(wp), intent(out) :: source - - real(wp) :: dist + real(wp) :: dist source = 0._wp if (support(ai) == 1) then ! 1D source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(r(1)/(sig/2._wp))**2._wp) - - elseif (support(ai) == 2 .or. support(ai) == 3) then ! 2D or 3D + else if (support(ai) == 2 .or. support(ai) == 3) then ! 2D or 3D ! If we let unit vector e = (cos(dir), sin(dir)), dist = r(1)*cos(dir(ai)) + r(2)*sin(dir(ai)) ! dot(r,e) - if ((r(1) - dist*cos(dir(ai)))**2._wp + (r(2) - dist*sin(dir(ai)))**2._wp < 0.25_wp*length(ai)**2._wp) then ! |r - dist*e| < length/2 + if ((r(1) - dist*cos(dir(ai)))**2._wp + (r(2) - dist*sin(dir(ai)))**2._wp < 0.25_wp*length(ai)**2._wp) & + & then ! |r - dist*e| < length/2 if (support(ai) /= 3 .or. abs(r(3)) < 0.25_wp*height(ai)) then ! additional height constraint for 3D source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(dist/(sig/2._wp))**2._wp) end if end if end if end subroutine s_source_spatial_planar - !> This subroutine calculates the spatial support for a single transducer in 2D, 2D axisymmetric, and 3D !! @param ai Acoustic source index !! @param sig Sigma value for the Gaussian distribution @@ -567,11 +548,10 @@ contains !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial_transducer(ai, sig, r, source, angle, xyz_to_r_ratios) - integer, intent(in) :: ai - real(wp), intent(in) :: sig, r(3) + integer, intent(in) :: ai + real(wp), intent(in) :: sig, r(3) real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) - - real(wp) :: current_angle, angle_half_aperture, dist, norm + real(wp) :: current_angle, angle_half_aperture, dist, norm source = 0._wp ! If not affected by transducer angle = 0._wp @@ -586,8 +566,7 @@ contains source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(dist/(sig/2._wp))**2._wp) angle = -atan(r(2)/(foc_length(ai) - r(1))) end if - - elseif (support(ai) == 7) then ! 3D + else if (support(ai) == 7) then ! 3D current_angle = -atan(sqrt(r(2)**2 + r(3)**2)/(foc_length(ai) - r(1))) angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai))) @@ -600,10 +579,8 @@ contains xyz_to_r_ratios(2) = -r(2)/norm xyz_to_r_ratios(3) = -r(3)/norm end if - end if end subroutine s_source_spatial_transducer - !> This subroutine calculates the spatial support for multiple transducers in 2D, 2D axisymmetric, and 3D !! @param ai Acoustic source index !! @param sig Sigma value for the Gaussian distribution @@ -612,15 +589,14 @@ contains !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios) - integer, intent(in) :: ai - real(wp), intent(in) :: sig, r(3) + integer, intent(in) :: ai + real(wp), intent(in) :: sig, r(3) real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) - - integer :: elem, elem_min, elem_max - real(wp) :: current_angle, angle_half_aperture, angle_per_elem, dist - real(wp) :: angle_min, angle_max, norm - real(wp) :: poly_side_length, aperture_element_3D, angle_elem - real(wp) :: x2, y2, z2, x3, y3, z3, C, f, half_apert, dist_interp_to_elem_center + integer :: elem, elem_min, elem_max + real(wp) :: current_angle, angle_half_aperture, angle_per_elem, dist + real(wp) :: angle_min, angle_max, norm + real(wp) :: poly_side_length, aperture_element_3D, angle_elem + real(wp) :: x2, y2, z2, x3, y3, z3, C, f, half_apert, dist_interp_to_elem_center if (element_on(ai) == 0) then ! Full transducer elem_min = 1 @@ -650,8 +626,7 @@ contains exit ! Assume elements don't overlap end if end do - - elseif (support(ai) == 11) then ! 3D + else if (support(ai) == 11) then ! 3D poly_side_length = aperture(ai)*sin(pi/num_elements(ai)) aperture_element_3D = poly_side_length*element_polygon_ratio(ai) f = foc_length(ai) @@ -682,12 +657,9 @@ contains xyz_to_r_ratios(2) = -r(2)/norm xyz_to_r_ratios(3) = -r(3)/norm end if - end do - end if end subroutine s_source_spatial_transducer_array - !> This function performs wavelength to frequency conversion !! @param freq_conv_flag Determines if frequency is given or wavelength !! @param ai Acoustic source index @@ -695,10 +667,10 @@ contains !! @return frequency_local Converted frequency elemental function f_frequency_local(freq_conv_flag, ai, c) $:GPU_ROUTINE(parallelism='[seq]') - logical, intent(in) :: freq_conv_flag - integer, intent(in) :: ai + logical, intent(in) :: freq_conv_flag + integer, intent(in) :: ai real(wp), intent(in) :: c - real(wp) :: f_frequency_local + real(wp) :: f_frequency_local if (freq_conv_flag) then f_frequency_local = c/wavelength(ai) @@ -706,7 +678,6 @@ contains f_frequency_local = frequency(ai) end if end function f_frequency_local - !> This function performs Gaussian sigma dist to time conversion !! @param gauss_conv_flag Determines if sigma_dist is given or sigma_time !! @param c Speed of sound @@ -714,10 +685,10 @@ contains !! @return gauss_sigma_time_local Converted Gaussian sigma time function f_gauss_sigma_time_local(gauss_conv_flag, ai, c) $:GPU_ROUTINE(parallelism='[seq]') - logical, intent(in) :: gauss_conv_flag - integer, intent(in) :: ai + logical, intent(in) :: gauss_conv_flag + integer, intent(in) :: ai real(wp), intent(in) :: c - real(wp) :: f_gauss_sigma_time_local + real(wp) :: f_gauss_sigma_time_local if (gauss_conv_flag) then f_gauss_sigma_time_local = gauss_sigma_dist(ai)/c @@ -725,5 +696,4 @@ contains f_gauss_sigma_time_local = gauss_sigma_time(ai) end if end function f_gauss_sigma_time_local - end module m_acoustic_src diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index 1b9b1a209b..5cd48f0a28 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -6,7 +6,6 @@ !> @brief Computes gravitational and user-defined body force source terms for the momentum equations module m_body_forces - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -15,102 +14,78 @@ module m_body_forces use m_nvtx -! $:USE_GPU_MODULE() + ! $:USE_GPU_MODULE() implicit none - private; - public :: s_compute_body_forces_rhs, & - s_initialize_body_forces_module, & - s_finalize_body_forces_module + private; + public :: s_compute_body_forces_rhs, s_initialize_body_forces_module, s_finalize_body_forces_module - real(wp), allocatable, dimension(:, :, :) :: rhoM + real(wp), allocatable, dimension(:,:,:) :: rhoM $:GPU_DECLARE(create='[rhoM]') - contains - !> This subroutine initializes the module global array of mixture - !! densities in each grid cell + !> This subroutine initializes the module global array of mixture densities in each grid cell impure subroutine s_initialize_body_forces_module - ! Simulation is at least 2D if (n > 0) then ! Simulation is 3D if (p > 0) then - @:ALLOCATE (rhoM(-buff_size:buff_size + m, & - -buff_size:buff_size + n, & - -buff_size:buff_size + p)) + @:ALLOCATE(rhoM(-buff_size:buff_size + m, -buff_size:buff_size + n, -buff_size:buff_size + p)) ! Simulation is 2D else - @:ALLOCATE (rhoM(-buff_size:buff_size + m, & - -buff_size:buff_size + n, & - 0:0)) + @:ALLOCATE(rhoM(-buff_size:buff_size + m, -buff_size:buff_size + n, 0:0)) end if ! Simulation is 1D else - @:ALLOCATE (rhoM(-buff_size:buff_size + m, & - 0:0, & - 0:0)) + @:ALLOCATE(rhoM(-buff_size:buff_size + m, 0:0, 0:0)) end if - end subroutine s_initialize_body_forces_module - !> This subroutine computes the acceleration at time t subroutine s_compute_acceleration(t) - real(wp), intent(in) :: t #:for DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (bf_${XYZ}$) then - accel_bf(${DIR}$) = g_${XYZ}$+k_${XYZ}$*sin(w_${XYZ}$*t - p_${XYZ}$) + accel_bf(${DIR}$) = g_${XYZ}$ + k_${XYZ}$*sin(w_${XYZ}$*t - p_${XYZ}$) end if #:endfor $:GPU_UPDATE(device='[accel_bf]') - end subroutine s_compute_acceleration - - !> This subroutine calculates the mixture density at each cell - !! center + !> This subroutine calculates the mixture density at each cell center !! @param q_cons_vf Conservative variables subroutine s_compute_mixture_density(q_cons_vf) - type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - integer :: i, j, k, l !< standard iterators + integer :: i, j, k, l !< standard iterators - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m rhoM(j, k, l) = 0._wp do i = 1, num_fluids - rhoM(j, k, l) = rhoM(j, k, l) + & - q_cons_vf(contxb + i - 1)%sf(j, k, l) + rhoM(j, k, l) = rhoM(j, k, l) + q_cons_vf(contxb + i - 1)%sf(j, k, l) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_compute_mixture_density - - !> This subroutine calculates the source term due to body forces - !! so the system can be advanced in time + !> This subroutine calculates the source term due to body forces so the system can be advanced in time !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables !! @param rhs_vf Right-hand side accumulator subroutine s_compute_body_forces_rhs(q_prim_vf, q_cons_vf, rhs_vf) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - - integer :: i, j, k, l !< Loop variables + integer :: i, j, k, l !< Loop variables call s_compute_acceleration(mytime) call s_compute_mixture_density(q_cons_vf) - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = momxb, E_idx do l = 0, p do k = 0, n @@ -124,14 +99,12 @@ contains if (bf_x) then ! x-direction body forces - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - rhoM(j, k, l)*accel_bf(1) - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - q_cons_vf(momxb)%sf(j, k, l)*accel_bf(1) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + rhoM(j, k, l)*accel_bf(1) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + q_cons_vf(momxb)%sf(j, k, l)*accel_bf(1) end do end do end do @@ -140,14 +113,12 @@ contains if (bf_y) then ! y-direction body forces - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - rhoM(j, k, l)*accel_bf(2) - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - q_cons_vf(momxb + 1)%sf(j, k, l)*accel_bf(2) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + rhoM(j, k, l)*accel_bf(2) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + q_cons_vf(momxb + 1)%sf(j, k, l)*accel_bf(2) end do end do end do @@ -156,28 +127,20 @@ contains if (bf_z) then ! z-direction body forces - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - rhs_vf(momxe)%sf(j, k, l) = rhs_vf(momxe)%sf(j, k, l) + & - rhoM(j, k, l)*accel_bf(3) - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - q_cons_vf(momxe)%sf(j, k, l)*accel_bf(3) + rhs_vf(momxe)%sf(j, k, l) = rhs_vf(momxe)%sf(j, k, l) + rhoM(j, k, l)*accel_bf(3) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + q_cons_vf(momxe)%sf(j, k, l)*accel_bf(3) end do end do end do $:END_GPU_PARALLEL_LOOP() - end if - end subroutine s_compute_body_forces_rhs - !> @brief Deallocates module variables used for body force computations. impure subroutine s_finalize_body_forces_module - @:DEALLOCATE(rhoM) - end subroutine s_finalize_body_forces_module - end module m_body_forces diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 0f17bd60c3..f0957e44b5 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -4,9 +4,9 @@ #:include 'macros.fpp' -!> @brief Shared bubble-dynamics procedures (radial acceleration, wall pressure, sound speed) for ensemble- and volume-averaged models +!> @brief Shared bubble-dynamics procedures (radial acceleration, wall pressure, sound speed) for ensemble- and volume-averaged +!! models module m_bubbles - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -22,32 +22,30 @@ module m_bubbles real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) real(wp) :: k_mw !< Bubble wall properties (Ando 2010) real(wp) :: rho_mw !< Bubble wall properties (Ando 2010) - $:GPU_DECLARE(create='[chi_vw,k_mw,rho_mw]') - + $:GPU_DECLARE(create='[chi_vw, k_mw, rho_mw]') contains !> Function that computes the bubble radial acceleration based on bubble models - !! @param fRho Current density - !! @param fP Current driving pressure - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpb Internal bubble pressure - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param alf bubble volume fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param f_bub_adv_src Source for bubble volume fraction - !! @param f_divu Divergence of velocity - !! @param fCson Speed of sound from fP (EL) + !! @param fRho Current density + !! @param fP Current driving pressure + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fR0 Equilibrium bubble radius + !! @param fpb Internal bubble pressure + !! @param fpbdot Time-derivative of internal bubble pressure + !! @param alf bubble volume fraction + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter + !! @param f_bub_adv_src Source for bubble volume fraction + !! @param f_divu Divergence of velocity + !! @param fCson Speed of sound from fP (EL) elemental function f_rddot(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf real(wp), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu real(wp), intent(in) :: fCson - - real(wp) :: fCpbw, fCpinf, fCpinf_dot, fH, fHdot, c_gas, c_liquid - real(wp) :: f_rddot + real(wp) :: fCpbw, fCpinf, fCpinf_dot, fH, fHdot, c_gas, c_liquid + real(wp) :: f_rddot if (bubble_model == 1) then ! Gilmore bubbles @@ -76,48 +74,40 @@ contains ! Default: No bubble dynamics f_rddot = 0._wp end if - end function f_rddot - - !> Function that computes that bubble wall pressure for Gilmore bubbles - !! @param fR0 Equilibrium bubble radius - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fpb Internal bubble pressure + !> Function that computes that bubble wall pressure for Gilmore bubbles + !! @param fR0 Equilibrium bubble radius + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fpb Internal bubble pressure elemental function f_cpbw(fR0, fR, fV, fpb) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fR0, fR, fV, fpb - - real(wp) :: f_cpbw + real(wp) :: f_cpbw if (polytropic) then f_cpbw = (Ca + 2._wp/Web/fR0)*((fR0/fR)**(3._wp*gam)) - Ca - 4._wp*Re_inv*fV/fR - 2._wp/(fR*Web) else f_cpbw = fpb - 1._wp - 4._wp*Re_inv*fV/fR - 2._wp/(fR*Web) end if - end function f_cpbw - - !> Function that computes the bubble enthalpy - !! @param fCpbw Bubble wall pressure - !! @param fCpinf Driving bubble pressure - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter + !> Function that computes the bubble enthalpy + !! @param fCpbw Bubble wall pressure + !! @param fCpinf Driving bubble pressure + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter elemental function f_H(fCpbw, fCpinf, fntait, fBtait) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCpbw, fCpinf, fntait, fBtait - - real(wp) :: tmp1, tmp2, tmp3 - real(wp) :: f_H + real(wp) :: tmp1, tmp2, tmp3 + real(wp) :: f_H tmp1 = (fntait - 1._wp)/fntait tmp2 = (fCpbw/(1._wp + fBtait) + 1._wp)**tmp1 tmp3 = (fCpinf/(1._wp + fBtait) + 1._wp)**tmp1 f_H = (tmp2 - tmp3)*fntait*(1._wp + fBtait)/(fntait - 1._wp) - end function f_H - !> Function that computes the sound speed for the bubble !! @param fCpinf Driving bubble pressure !! @param fntait Tait EOS parameter @@ -126,32 +116,28 @@ contains elemental function f_cgas(fCpinf, fntait, fBtait, fH) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCpinf, fntait, fBtait, fH - - real(wp) :: tmp - real(wp) :: f_cgas + real(wp) :: tmp + real(wp) :: f_cgas ! get sound speed for Gilmore equations "C" -> c_gas tmp = (fCpinf/(1._wp + fBtait) + 1._wp)**((fntait - 1._wp)/fntait) tmp = fntait*(1._wp + fBtait)*tmp f_cgas = sqrt(tmp + (fntait - 1._wp)*fH) - end function f_cgas - - !> Function that computes the time derivative of the driving pressure - !! @param fRho Local liquid density - !! @param fP Local pressure - !! @param falf Local void fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param advsrc Advection equation source term - !! @param divu Divergence of velocity + !> Function that computes the time derivative of the driving pressure + !! @param fRho Local liquid density + !! @param fP Local pressure + !! @param falf Local void fraction + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter + !! @param advsrc Advection equation source term + !! @param divu Divergence of velocity elemental function f_cpinfdot(fRho, fP, falf, fntait, fBtait, advsrc, divu) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fRho, fP, falf, fntait, fBtait, advsrc, divu - - real(wp) :: c2_liquid - real(wp) :: f_cpinfdot + real(wp) :: c2_liquid + real(wp) :: f_cpinfdot ! get sound speed squared for liquid (only needed for pbdot) ! c_l^2 = gam (p+B) / (rho*(1-alf)) @@ -163,26 +149,23 @@ contains ! \dot{Cp_inf} = rho sound^2 (alf_src - divu) f_cpinfdot = fRho*c2_liquid*(advsrc - divu) - end function f_cpinfdot - - !> Function that computes the time derivative of the enthalpy - !! @param fCpbw Bubble wall pressure - !! @param fCpinf Driving bubble pressure - !! @param fCpinf_dot Time derivative of the driving pressure - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpbdot Time derivative of the internal bubble pressure + !> Function that computes the time derivative of the enthalpy + !! @param fCpbw Bubble wall pressure + !! @param fCpinf Driving bubble pressure + !! @param fCpinf_dot Time derivative of the driving pressure + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fR0 Equilibrium bubble radius + !! @param fpbdot Time derivative of the internal bubble pressure elemental function f_Hdot(fCpbw, fCpinf, fCpinf_dot, fntait, fBtait, fR, fV, fR0, fpbdot) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCpbw, fCpinf, fCpinf_dot, fntait, fBtait real(wp), intent(in) :: fR, fV, fR0, fpbdot - - real(wp) :: tmp1, tmp2 - real(wp) :: f_Hdot + real(wp) :: tmp1, tmp2 + real(wp) :: f_Hdot if (polytropic) then tmp1 = (fR0/fR)**(3._wp*gam) @@ -192,109 +175,93 @@ contains end if tmp2 = (2._wp/Web + 4._wp*Re_inv*fV)*fV/(fR**2._wp) - f_Hdot = & - (fCpbw/(1._wp + fBtait) + 1._wp)**(-1._wp/fntait)*(tmp1 + tmp2) & - - (fCpinf/(1._wp + fBtait) + 1._wp)**(-1._wp/fntait)*fCpinf_dot + f_Hdot = (fCpbw/(1._wp + fBtait) + 1._wp)**(-1._wp/fntait)*(tmp1 + tmp2) - (fCpinf/(1._wp + fBtait) + 1._wp) & + & **(-1._wp/fntait)*fCpinf_dot ! Hdot = (Cpbw/(1+B) + 1)^(-1/n_tait)*(-3 gam)*(R0/R)^(3gam) V/R - !f_Hdot = ((fCpbw/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*(-3._wp)*gam * & + ! f_Hdot = ((fCpbw/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*(-3._wp)*gam * & ! ( (fR0/fR)**(3._wp*gam ))*(fV/fR) ! Hdot = Hdot - (Cpinf/(1+B) + 1)^(-1/n_tait) Cpinfdot - !f_Hdot = f_Hdot - ((fCpinf/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*fCpinf_dot - + ! f_Hdot = f_Hdot - ((fCpinf/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*fCpinf_dot end function f_Hdot - - !> Function that computes the bubble radial acceleration for Rayleigh-Plesset bubbles - !! @param fCp Driving pressure - !! @param fRho Current density - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fCpbw Boundary wall pressure + !> Function that computes the bubble radial acceleration for Rayleigh-Plesset bubbles + !! @param fCp Driving pressure + !! @param fRho Current density + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fCpbw Boundary wall pressure elemental function f_rddot_RP(fCp, fRho, fR, fV, fCpbw) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCp, fRho, fR, fV, fCpbw - - real(wp) :: f_rddot_RP + real(wp) :: f_rddot_RP !! rddot = (1/r) ( -3/2 rdot^2 + ((r0/r)^3\gamma - Cp)/rho ) !! rddot = (1/r) ( -3/2 rdot^2 + (tmp1 - Cp)/rho ) !! rddot = (1/r) ( tmp2 ) f_rddot_RP = (-1.5_wp*(fV**2._wp) + (fCpbw - fCp)/fRho)/fR - end function f_rddot_RP - - !> Function that computes the bubble radial acceleration - !! @param fCpbw Bubble wall pressure - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fH Current enthalpy - !! @param fHdot Current time derivative of the enthalpy - !! @param fcgas Current gas sound speed - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter + !> Function that computes the bubble radial acceleration + !! @param fCpbw Bubble wall pressure + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fH Current enthalpy + !! @param fHdot Current time derivative of the enthalpy + !! @param fcgas Current gas sound speed + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter elemental function f_rddot_G(fCpbw, fR, fV, fH, fHdot, fcgas, fntait, fBtait) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCpbw, fR, fV, fH, fHdot real(wp), intent(in) :: fcgas, fntait, fBtait - - real(wp) :: tmp1, tmp2, tmp3 - real(wp) :: f_rddot_G + real(wp) :: tmp1, tmp2, tmp3 + real(wp) :: f_rddot_G tmp1 = fV/fcgas - tmp2 = 1._wp + 4._wp*Re_inv/fcgas/fR*(fCpbw/(1._wp + fBtait) + 1._wp) & - **(-1._wp/fntait) - tmp3 = 1.5_wp*fV**2._wp*(tmp1/3._wp - 1._wp) + fH*(1._wp + tmp1) & - + fR*fHdot*(1._wp - tmp1)/fcgas + tmp2 = 1._wp + 4._wp*Re_inv/fcgas/fR*(fCpbw/(1._wp + fBtait) + 1._wp)**(-1._wp/fntait) + tmp3 = 1.5_wp*fV**2._wp*(tmp1/3._wp - 1._wp) + fH*(1._wp + tmp1) + fR*fHdot*(1._wp - tmp1)/fcgas f_rddot_G = tmp3/(fR*(1._wp - tmp1)*tmp2) - end function f_rddot_G - - !> Function that computes the bubble wall pressure for Keller--Miksis bubbles - !! @param fR0 Equilibrium bubble radius - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fpb Internal bubble pressure + !> Function that computes the bubble wall pressure for Keller--Miksis bubbles + !! @param fR0 Equilibrium bubble radius + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fpb Internal bubble pressure elemental function f_cpbw_KM(fR0, fR, fV, fpb) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fR0, fR, fV, fpb - real(wp) :: f_cpbw_KM + real(wp) :: f_cpbw_KM if (polytropic) then f_cpbw_KM = Ca*((fR0/fR)**(3._wp*gam)) - Ca + Eu - if (.not. f_is_default(Web)) f_cpbw_KM = f_cpbw_KM + & - (2._wp/(Web*fR0))*((fR0/fR)**(3._wp*gam)) + if (.not. f_is_default(Web)) f_cpbw_KM = f_cpbw_KM + (2._wp/(Web*fR0))*((fR0/fR)**(3._wp*gam)) else f_cpbw_KM = fpb end if if (.not. f_is_default(Web)) f_cpbw_KM = f_cpbw_KM - 2._wp/(fR*Web) if (.not. f_is_default(Re_inv)) f_cpbw_KM = f_cpbw_KM - 4._wp*Re_inv*fV/fR - end function f_cpbw_KM - - !> Function that computes the bubble radial acceleration for Keller--Miksis bubbles - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param fCp Driving pressure - !! @param fCpbw Bubble wall pressure - !! @param fRho Current density - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fC Current sound speed + !> Function that computes the bubble radial acceleration for Keller--Miksis bubbles + !! @param fpbdot Time-derivative of internal bubble pressure + !! @param fCp Driving pressure + !! @param fCpbw Bubble wall pressure + !! @param fRho Current density + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fR0 Equilibrium bubble radius + !! @param fC Current sound speed elemental function f_rddot_KM(fpbdot, fCp, fCpbw, fRho, fR, fV, fR0, fC) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fpbdot, fCp, fCpbw real(wp), intent(in) :: fRho, fR, fV, fR0, fC - - real(wp) :: tmp1, tmp2, cdot_star - real(wp) :: f_rddot_KM + real(wp) :: tmp1, tmp2, cdot_star + real(wp) :: f_rddot_KM if (polytropic) then cdot_star = -3._wp*gam*Ca*((fR0/fR)**(3._wp*gam))*fV/fR - if (.not. f_is_default(Web)) cdot_star = cdot_star - & - 3._wp*gam*(2._wp/(Web*fR0))*((fR0/fR)**(3._wp*gam))*fV/fR + if (.not. f_is_default(Web)) cdot_star = cdot_star - 3._wp*gam*(2._wp/(Web*fR0))*((fR0/fR)**(3._wp*gam))*fV/fR else cdot_star = fpbdot end if @@ -303,69 +270,61 @@ contains if (.not. f_is_default(Re_inv)) cdot_star = cdot_star + 4._wp*Re_inv*((fV/fR)**2._wp) tmp1 = fV/fC - tmp2 = 1.5_wp*(fV**2._wp)*(tmp1/3._wp - 1._wp) + & - (1._wp + tmp1)*(fCpbw - fCp)/fRho + & - cdot_star*fR/(fRho*fC) + tmp2 = 1.5_wp*(fV**2._wp)*(tmp1/3._wp - 1._wp) + (1._wp + tmp1)*(fCpbw - fCp)/fRho + cdot_star*fR/(fRho*fC) if (f_is_default(Re_inv)) then f_rddot_KM = tmp2/(fR*(1._wp - tmp1)) else f_rddot_KM = tmp2/(fR*(1._wp - tmp1) + 4._wp*Re_inv/(fRho*fC)) end if - end function f_rddot_KM - - !> Subroutine that computes bubble wall properties for vapor bubbles - !! @param pb_in Internal bubble pressure - !! @param iR0 Current bubble size index + !> Subroutine that computes bubble wall properties for vapor bubbles + !! @param pb_in Internal bubble pressure + !! @param iR0 Current bubble size index elemental subroutine s_bwproperty(pb_in, iR0, chi_vw_out, k_mw_out, rho_mw_out) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: pb_in - integer, intent(in) :: iR0 + real(wp), intent(in) :: pb_in + integer, intent(in) :: iR0 real(wp), intent(out) :: chi_vw_out !< Bubble wall properties (Ando 2010) real(wp), intent(out) :: k_mw_out !< Bubble wall properties (Ando 2010) real(wp), intent(out) :: rho_mw_out !< Bubble wall properties (Ando 2010) - real(wp) :: x_vw + real(wp) :: x_vw ! mass fraction of vapor chi_vw_out = 1._wp/(1._wp + R_v/R_g*(pb_in/pv - 1._wp)) ! mole fraction of vapor & thermal conductivity of gas mixture x_vw = M_g*chi_vw_out/(M_v + (M_g - M_v)*chi_vw_out) - k_mw_out = x_vw*k_v(iR0)/(x_vw + (1._wp - x_vw)*phi_vg) & - + (1._wp - x_vw)*k_g(iR0)/(x_vw*phi_gv + 1._wp - x_vw) + k_mw_out = x_vw*k_v(iR0)/(x_vw + (1._wp - x_vw)*phi_vg) + (1._wp - x_vw)*k_g(iR0)/(x_vw*phi_gv + 1._wp - x_vw) ! gas mixture density rho_mw_out = pv/(chi_vw_out*R_v*Tw) - end subroutine s_bwproperty - - !> Function that computes the vapour flux - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fpb - !! @param fmass_v Current mass of vapour - !! @param iR0 Bubble size index (EE) or bubble identifier (EL) - !! @param vflux Computed vapour flux - !! @param fmass_g Current gas mass (EL) - !! @param fbeta_c Mass transfer coefficient (EL) - !! @param fR_m Mixture gas constant (EL) - !! @param fgamma_m Mixture gamma (EL) + !> Function that computes the vapour flux + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fpb + !! @param fmass_v Current mass of vapour + !! @param iR0 Bubble size index (EE) or bubble identifier (EL) + !! @param vflux Computed vapour flux + !! @param fmass_g Current gas mass (EL) + !! @param fbeta_c Mass transfer coefficient (EL) + !! @param fR_m Mixture gas constant (EL) + !! @param fgamma_m Mixture gamma (EL) elemental subroutine s_vflux(fR, fV, fpb, fmass_v, iR0, vflux, fmass_g, fbeta_c, fR_m, fgamma_m) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: fR - real(wp), intent(in) :: fV - real(wp), intent(in) :: fpb - real(wp), intent(in) :: fmass_v - integer, intent(in) :: iR0 - real(wp), intent(out) :: vflux - real(wp), intent(in), optional :: fmass_g, fbeta_c + real(wp), intent(in) :: fR + real(wp), intent(in) :: fV + real(wp), intent(in) :: fpb + real(wp), intent(in) :: fmass_v + integer, intent(in) :: iR0 + real(wp), intent(out) :: vflux + real(wp), intent(in), optional :: fmass_g, fbeta_c real(wp), intent(out), optional :: fR_m, fgamma_m + real(wp) :: chi_bar + real(wp) :: rho_mw_lag + real(wp) :: grad_chi + real(wp) :: conc_v - real(wp) :: chi_bar - real(wp) :: rho_mw_lag - real(wp) :: grad_chi - real(wp) :: conc_v - - if (thermal == 3) then !transfer + if (thermal == 3) then ! transfer ! constant transfer model if (bubbles_lagrange) then ! Mixture properties (gas+vapor) in the bubble @@ -393,100 +352,87 @@ contains ! polytropic vflux = pv*fV/(R_v*Tw) end if - end subroutine s_vflux - - !> Function that computes the time derivative of - !! the internal bubble pressure - !! @param fvflux Vapour flux - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fpb Current internal bubble pressure - !! @param fmass_v Current mass of vapour - !! @param iR0 Bubble size index (EE) or bubble identifier (EL) - !! @param fbeta_t Mass transfer coefficient (EL) - !! @param fR_m Mixture gas constant (EL) - !! @param fgamma_m Mixture gamma (EL) + !> Function that computes the time derivative of the internal bubble pressure + !! @param fvflux Vapour flux + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fpb Current internal bubble pressure + !! @param fmass_v Current mass of vapour + !! @param iR0 Bubble size index (EE) or bubble identifier (EL) + !! @param fbeta_t Mass transfer coefficient (EL) + !! @param fR_m Mixture gas constant (EL) + !! @param fgamma_m Mixture gamma (EL) elemental function f_bpres_dot(fvflux, fR, fV, fpb, fmass_v, iR0, fbeta_t, fR_m, fgamma_m) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: fvflux - real(wp), intent(in) :: fR - real(wp), intent(in) :: fV - real(wp), intent(in) :: fpb - real(wp), intent(in) :: fmass_v - integer, intent(in) :: iR0 + real(wp), intent(in) :: fvflux + real(wp), intent(in) :: fR + real(wp), intent(in) :: fV + real(wp), intent(in) :: fpb + real(wp), intent(in) :: fmass_v + integer, intent(in) :: iR0 real(wp), intent(in), optional :: fbeta_t, fR_m, fgamma_m - - real(wp) :: T_bar - real(wp) :: grad_T - real(wp) :: f_bpres_dot - real(wp) :: heatflux + real(wp) :: T_bar + real(wp) :: grad_T + real(wp) :: f_bpres_dot + real(wp) :: heatflux if (thermal == 3) then if (bubbles_lagrange) then T_bar = fpb*(4._wp/3._wp*pi*fR**3._wp)/fR_m grad_T = -fbeta_t*(T_bar - Tw) heatflux = (fgamma_m - 1._wp)/fgamma_m*grad_T/fR - f_bpres_dot = 3._wp*fgamma_m*(-fV*fpb + fvflux*R_v*Tw & - + heatflux)/fR + f_bpres_dot = 3._wp*fgamma_m*(-fV*fpb + fvflux*R_v*Tw + heatflux)/fR return end if - grad_T = -Re_trans_T(iR0)*((fpb/pb0(iR0))*(fR/R0(iR0))**3 & - *(mass_g0(iR0) + mass_v0(iR0))/(mass_g0(iR0) + fmass_v) - 1._wp) - f_bpres_dot = 3._wp*gam_m*(-fV*fpb + fvflux*R_v*Tw & - + pb0(iR0)*k_mw*grad_T/Pe_T(iR0)/fR)/fR + grad_T = -Re_trans_T(iR0)*((fpb/pb0(iR0))*(fR/R0(iR0))**3*(mass_g0(iR0) + mass_v0(iR0))/(mass_g0(iR0) + fmass_v) & + & - 1._wp) + f_bpres_dot = 3._wp*gam_m*(-fV*fpb + fvflux*R_v*Tw + pb0(iR0)*k_mw*grad_T/Pe_T(iR0)/fR)/fR else f_bpres_dot = -3._wp*gam_m*fV/fR*(fpb - pv) end if - end function f_bpres_dot - - !> Adaptive time stepping routine for subgrid bubbles - !! (See Heirer, E. Hairer S.P.Nørsett G. Wanner, Solving Ordinary - !! Differential Equations I, Chapter II.4) - !! @param fRho Current density - !! @param fP Current driving pressure - !! @param fR Current bubble radius - !! @param fV Current bubble radial velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpb Internal bubble pressure - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param alf bubble volume fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param f_bub_adv_src Source for bubble volume fraction - !! @param f_divu Divergence of velocity - !! @param bub_id Bubble identifier (EL) - !! @param fmass_v Current mass of vapour (EL) - !! @param fmass_g Current mass of gas (EL) - !! @param fbeta_c Mass transfer coefficient (EL) - !! @param fbeta_t Heat transfer coefficient (EL) - !! @param fCson Speed of sound (EL) - !! @param adap_dt_stop Fail-safe exit if max iteration count reached - subroutine s_advance_step(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, & - fntait, fBtait, f_bub_adv_src, f_divu, & - bub_id, fmass_v, fmass_g, fbeta_c, & - fbeta_t, fCson, adap_dt_stop) - $:GPU_ROUTINE(function_name='s_advance_step',parallelism='[seq]', & - & cray_inline=True) + !> Adaptive time stepping routine for subgrid bubbles (See Heirer, E. Hairer S.P.Norsett G. Wanner, Solving Ordinary + !! Differential Equations I, Chapter II.4) + !! @param fRho Current density + !! @param fP Current driving pressure + !! @param fR Current bubble radius + !! @param fV Current bubble radial velocity + !! @param fR0 Equilibrium bubble radius + !! @param fpb Internal bubble pressure + !! @param fpbdot Time-derivative of internal bubble pressure + !! @param alf bubble volume fraction + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter + !! @param f_bub_adv_src Source for bubble volume fraction + !! @param f_divu Divergence of velocity + !! @param bub_id Bubble identifier (EL) + !! @param fmass_v Current mass of vapour (EL) + !! @param fmass_g Current mass of gas (EL) + !! @param fbeta_c Mass transfer coefficient (EL) + !! @param fbeta_t Heat transfer coefficient (EL) + !! @param fCson Speed of sound (EL) + !! @param adap_dt_stop Fail-safe exit if max iteration count reached + subroutine s_advance_step(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, bub_id, fmass_v, & + & fmass_g, fbeta_c, fbeta_t, fCson, adap_dt_stop) + $:GPU_ROUTINE(function_name='s_advance_step',parallelism='[seq]', cray_inline=True) real(wp), intent(inout) :: fR, fV, fpb, fmass_v - real(wp), intent(in) :: fRho, fP, fR0, fpbdot, alf - real(wp), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu - integer, intent(in) :: bub_id - real(wp), intent(in) :: fmass_g, fbeta_c, fbeta_t, fCson - integer, intent(inout) :: adap_dt_stop - - real(wp), dimension(5) :: err !< Error estimates for adaptive time stepping - real(wp) :: t_new !< Updated time step size - real(wp) :: h0, h !< Time step size - real(wp), dimension(4) :: myR_tmp1, myV_tmp1, myR_tmp2, myV_tmp2 !< Bubble radius, radial velocity, and radial acceleration for the inner loop + real(wp), intent(in) :: fRho, fP, fR0, fpbdot, alf + real(wp), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu + integer, intent(in) :: bub_id + real(wp), intent(in) :: fmass_g, fbeta_c, fbeta_t, fCson + integer, intent(inout) :: adap_dt_stop + real(wp), dimension(5) :: err !< Error estimates for adaptive time stepping + real(wp) :: t_new !< Updated time step size + real(wp) :: h0, h !< Time step size + real(wp), dimension(4) :: myR_tmp1, myV_tmp1, myR_tmp2, & + & myV_tmp2 !< Bubble radius, radial velocity, and radial acceleration for the inner loop real(wp), dimension(4) :: myPb_tmp1, myMv_tmp1, myPb_tmp2, myMv_tmp2 !< Gas pressure and vapor mass for the inner loop (EL) - real(wp) :: fR2, fV2, fpb2, fmass_v2 - integer :: iter_count + real(wp) :: fR2, fV2, fpb2, fmass_v2 + integer :: iter_count - call s_initial_substep_h(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, & - fntait, fBtait, f_bub_adv_src, f_divu, fCson, h0) + call s_initial_substep_h(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson, h0) h = h0 ! Advancing one step t_new = 0._wp @@ -500,28 +446,21 @@ contains ! Advancing one sub-step do while (iter_count < adap_dt_max_iters) - iter_count = iter_count + 1 ! Advance one sub-step - call s_advance_substep(err(1), & - fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, & - fntait, fBtait, f_bub_adv_src, f_divu, & - bub_id, fmass_v, fmass_g, fbeta_c, & - fbeta_t, fCson, h, & - myR_tmp1, myV_tmp1, myPb_tmp1, myMv_tmp1) + call s_advance_substep(err(1), fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & + & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp1, myV_tmp1, myPb_tmp1, & + & myMv_tmp1) if (err(1) > adap_dt_tol) then h = 0.25_wp*h cycle end if ! Advance one sub-step by advancing two half steps - call s_advance_substep(err(2), & - fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, & - fntait, fBtait, f_bub_adv_src, f_divu, & - bub_id, fmass_v, fmass_g, fbeta_c, & - fbeta_t, fCson, 0.5_wp*h, & - myR_tmp2, myV_tmp2, myPb_tmp2, myMv_tmp2) + call s_advance_substep(err(2), fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & + & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, & + & myPb_tmp2, myMv_tmp2) if (err(2) > adap_dt_tol) then h = 0.25_wp*h cycle @@ -530,12 +469,9 @@ contains fR2 = myR_tmp2(4); fV2 = myV_tmp2(4) fpb2 = myPb_tmp2(4); fmass_v2 = myMv_tmp2(4) - call s_advance_substep(err(3), & - fRho, fP, fR2, fV2, fR0, fpb2, fpbdot, alf, & - fntait, fBtait, f_bub_adv_src, f_divu, & - bub_id, fmass_v2, fmass_g, fbeta_c, & - fbeta_t, fCson, 0.5_wp*h, & - myR_tmp2, myV_tmp2, myPb_tmp2, myMv_tmp2) + call s_advance_substep(err(3), fRho, fP, fR2, fV2, fR0, fpb2, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & + & bub_id, fmass_v2, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, & + & myPb_tmp2, myMv_tmp2) if (err(3) > adap_dt_tol) then h = 0.5_wp*h cycle @@ -550,10 +486,8 @@ contains ! Rule 2: myR_tmp1(4) > 0._wp ! Rule 3: abs((myR_tmp1(4) - myR_tmp2(4))/fR) < tol ! Rule 4: abs((myV_tmp1(4) - myV_tmp2(4))/fV) < tol - if ((err(1) <= adap_dt_tol) .and. (err(2) <= adap_dt_tol) .and. & - (err(3) <= adap_dt_tol) .and. (err(4) <= adap_dt_tol) .and. & - (err(5) <= adap_dt_tol) .and. myR_tmp1(4) > 0._wp) then - + if ((err(1) <= adap_dt_tol) .and. (err(2) <= adap_dt_tol) .and. (err(3) <= adap_dt_tol) .and. (err(4) & + & <= adap_dt_tol) .and. (err(5) <= adap_dt_tol) .and. myR_tmp1(4) > 0._wp) then ! Accepted. Finalize the sub-step t_new = t_new + h @@ -583,41 +517,33 @@ contains ! Exit the loop if the final time reached dt if (f_approx_equal(t_new, 0.5_wp*dt) .or. iter_count >= adap_dt_max_iters) exit - end do if (iter_count >= adap_dt_max_iters) adap_dt_stop = 1 - end subroutine s_advance_step - - !> Choose the initial time step size for the adaptive time stepping routine - !! (See Heirer, E. Hairer S.P.Nørsett G. Wanner, Solving Ordinary - !! Differential Equations I, Chapter II.4) - !! @param fRho Current density - !! @param fP Current driving pressure - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpb Internal bubble pressure - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param alf bubble volume fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param f_bub_adv_src Source for bubble volume fraction - !! @param f_divu Divergence of velocity - !! @param fCson Speed of sound (EL) - !! @param h Time step size - subroutine s_initial_substep_h(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, & - fntait, fBtait, f_bub_adv_src, f_divu, & - fCson, h) - $:GPU_ROUTINE(function_name='s_initial_substep_h',parallelism='[seq]', & - & cray_inline=True) - - real(wp), intent(IN) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf - real(wp), intent(IN) :: fntait, fBtait, f_bub_adv_src, f_divu - real(wp), intent(IN) :: fCson - real(wp), intent(OUT) :: h - + !> Choose the initial time step size for the adaptive time stepping routine (See Heirer, E. Hairer S.P.Norsett G. Wanner, + !! Solving Ordinary Differential Equations I, Chapter II.4) + !! @param fRho Current density + !! @param fP Current driving pressure + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fR0 Equilibrium bubble radius + !! @param fpb Internal bubble pressure + !! @param fpbdot Time-derivative of internal bubble pressure + !! @param alf bubble volume fraction + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter + !! @param f_bub_adv_src Source for bubble volume fraction + !! @param f_divu Divergence of velocity + !! @param fCson Speed of sound (EL) + !! @param h Time step size + subroutine s_initial_substep_h(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson, h) + $:GPU_ROUTINE(function_name='s_initial_substep_h',parallelism='[seq]', cray_inline=True) + + real(wp), intent(in) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf + real(wp), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu + real(wp), intent(in) :: fCson + real(wp), intent(out) :: h real(wp), dimension(2) :: h_size !< Time step size (h0, h1) real(wp), dimension(3) :: d_norms !< norms (d_0, d_1, d_2) real(wp), dimension(2) :: myR_tmp, myV_tmp, myA_tmp !< Bubble radius, radial velocity, and radial acceleration @@ -626,10 +552,7 @@ contains ! Evaluate f(x0,y0) myR_tmp(1) = fR myV_tmp(1) = fV - myA_tmp(1) = f_rddot(fRho, fP, myR_tmp(1), myV_tmp(1), fR0, & - fpb, fpbdot, alf, fntait, fBtait, & - f_bub_adv_src, f_divu, & - fCson) + myA_tmp(1) = f_rddot(fRho, fP, myR_tmp(1), myV_tmp(1), fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson) ! Compute d_0 = ||y0|| and d_1 = ||f(x0,y0)|| d_norms(1) = sqrt((myR_tmp(1)**2._wp + myV_tmp(1)**2._wp)/2._wp) @@ -643,10 +566,7 @@ contains ! Evaluate f(x0+h0,y0+h0*f(x0,y0)) myR_tmp(2) = myR_tmp(1) + h_size(1)*myV_tmp(1) myV_tmp(2) = myV_tmp(1) + h_size(1)*myA_tmp(1) - myA_tmp(2) = f_rddot(fRho, fP, myR_tmp(2), myV_tmp(2), fR0, & - fpb, fpbdot, alf, fntait, fBtait, & - f_bub_adv_src, f_divu, & - fCson) + myA_tmp(2) = f_rddot(fRho, fP, myR_tmp(2), myV_tmp(2), fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson) ! Compute d_2 = ||f(x0+h0,y0+h0*f(x0,y0))-f(x0,y0)||/h0 d_norms(3) = sqrt(((myV_tmp(2) - myV_tmp(1))**2._wp + (myA_tmp(2) - myA_tmp(1))**2._wp)/2._wp)/h_size(1) @@ -660,52 +580,44 @@ contains end if h = min(h_size(1)/scale_guess, h_size(2)) - end subroutine s_initial_substep_h - - !> Integrate bubble variables over the given time step size, h, using a - !! third-order accurate embedded Runge–Kutta scheme. - !! @param err Estimated error - !! @param fRho Current density - !! @param fP Current driving pressure - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpb Internal bubble pressure - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param alf bubble volume fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param f_bub_adv_src Source for bubble volume fraction - !! @param f_divu Divergence of velocity - !! @param bub_id Bubble identifier (EL) - !! @param fmass_v Current mass of vapour (EL) - !! @param fmass_g Current mass of gas (EL) - !! @param fbeta_c Mass transfer coefficient (EL) - !! @param fbeta_t Heat transfer coefficient (EL) - !! @param fCson Speed of sound (EL) - !! @param h Time step size - !! @param myR_tmp Bubble radius at each stage - !! @param myV_tmp Bubble radial velocity at each stage - !! @param myPb_tmp Internal bubble pressure at each stage (EL) - !! @param myMv_tmp Mass of vapor in the bubble at each stage (EL) - subroutine s_advance_substep(err, fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, & - fntait, fBtait, f_bub_adv_src, f_divu, & - bub_id, fmass_v, fmass_g, fbeta_c, & - fbeta_t, fCson, h, & - myR_tmp, myV_tmp, myPb_tmp, myMv_tmp) - $:GPU_ROUTINE(function_name='s_advance_substep',parallelism='[seq]', & - & cray_inline=True) - - real(wp), intent(OUT) :: err - real(wp), intent(IN) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf - real(wp), intent(IN) :: fntait, fBtait, f_bub_adv_src, f_divu, h - integer, intent(IN) :: bub_id - real(wp), intent(IN) :: fmass_v, fmass_g, fbeta_c, fbeta_t, fCson - real(wp), dimension(4), intent(OUT) :: myR_tmp, myV_tmp, myPb_tmp, myMv_tmp - - real(wp), dimension(4) :: myA_tmp, mydPbdt_tmp, mydMvdt_tmp - real(wp) :: err_R, err_V + !> Integrate bubble variables over the given time step size, h, using a third-order accurate embedded Runge-Kutta scheme. + !! @param err Estimated error + !! @param fRho Current density + !! @param fP Current driving pressure + !! @param fR Current bubble radius + !! @param fV Current bubble velocity + !! @param fR0 Equilibrium bubble radius + !! @param fpb Internal bubble pressure + !! @param fpbdot Time-derivative of internal bubble pressure + !! @param alf bubble volume fraction + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter + !! @param f_bub_adv_src Source for bubble volume fraction + !! @param f_divu Divergence of velocity + !! @param bub_id Bubble identifier (EL) + !! @param fmass_v Current mass of vapour (EL) + !! @param fmass_g Current mass of gas (EL) + !! @param fbeta_c Mass transfer coefficient (EL) + !! @param fbeta_t Heat transfer coefficient (EL) + !! @param fCson Speed of sound (EL) + !! @param h Time step size + !! @param myR_tmp Bubble radius at each stage + !! @param myV_tmp Bubble radial velocity at each stage + !! @param myPb_tmp Internal bubble pressure at each stage (EL) + !! @param myMv_tmp Mass of vapor in the bubble at each stage (EL) + subroutine s_advance_substep(err, fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, bub_id, & + & fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp, myV_tmp, myPb_tmp, myMv_tmp) + $:GPU_ROUTINE(function_name='s_advance_substep',parallelism='[seq]', cray_inline=True) + + real(wp), intent(out) :: err + real(wp), intent(in) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf + real(wp), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu, h + integer, intent(in) :: bub_id + real(wp), intent(in) :: fmass_v, fmass_g, fbeta_c, fbeta_t, fCson + real(wp), dimension(4), intent(out) :: myR_tmp, myV_tmp, myPb_tmp, myMv_tmp + real(wp), dimension(4) :: myA_tmp, mydPbdt_tmp, mydMvdt_tmp + real(wp) :: err_R, err_V myPb_tmp(1:4) = fpb mydPbdt_tmp(1:4) = fpbdot @@ -716,13 +628,11 @@ contains if (bubbles_lagrange) then myPb_tmp(1) = fpb myMv_tmp(1) = fmass_v - call s_advance_EL(myR_tmp(1), myV_tmp(1), myPb_tmp(1), myMv_tmp(1), bub_id, & - fmass_g, fbeta_c, fbeta_t, mydPbdt_tmp(1), mydMvdt_tmp(1)) + call s_advance_EL(myR_tmp(1), myV_tmp(1), myPb_tmp(1), myMv_tmp(1), bub_id, fmass_g, fbeta_c, fbeta_t, & + & mydPbdt_tmp(1), mydMvdt_tmp(1)) end if - myA_tmp(1) = f_rddot(fRho, fP, myR_tmp(1), myV_tmp(1), fR0, & - myPb_tmp(1), mydPbdt_tmp(1), alf, fntait, fBtait, & - f_bub_adv_src, f_divu, & - fCson) + myA_tmp(1) = f_rddot(fRho, fP, myR_tmp(1), myV_tmp(1), fR0, myPb_tmp(1), mydPbdt_tmp(1), alf, fntait, fBtait, & + & f_bub_adv_src, f_divu, fCson) ! Stage 1 myR_tmp(2) = myR_tmp(1) + h*myV_tmp(1) @@ -733,13 +643,11 @@ contains if (bubbles_lagrange) then myPb_tmp(2) = myPb_tmp(1) + h*mydPbdt_tmp(1) myMv_tmp(2) = myMv_tmp(1) + h*mydMvdt_tmp(1) - call s_advance_EL(myR_tmp(2), myV_tmp(2), myPb_tmp(2), myMv_tmp(2), & - bub_id, fmass_g, fbeta_c, fbeta_t, mydPbdt_tmp(2), mydMvdt_tmp(2)) + call s_advance_EL(myR_tmp(2), myV_tmp(2), myPb_tmp(2), myMv_tmp(2), bub_id, fmass_g, fbeta_c, fbeta_t, & + & mydPbdt_tmp(2), mydMvdt_tmp(2)) end if - myA_tmp(2) = f_rddot(fRho, fP, myR_tmp(2), myV_tmp(2), fR0, & - myPb_tmp(2), mydPbdt_tmp(2), alf, fntait, fBtait, & - f_bub_adv_src, f_divu, & - fCson) + myA_tmp(2) = f_rddot(fRho, fP, myR_tmp(2), myV_tmp(2), fR0, myPb_tmp(2), mydPbdt_tmp(2), alf, fntait, fBtait, & + & f_bub_adv_src, f_divu, fCson) ! Stage 2 myR_tmp(3) = myR_tmp(1) + (h/4._wp)*(myV_tmp(1) + myV_tmp(2)) @@ -750,13 +658,11 @@ contains if (bubbles_lagrange) then myPb_tmp(3) = myPb_tmp(1) + (h/4._wp)*(mydPbdt_tmp(1) + mydPbdt_tmp(2)) myMv_tmp(3) = myMv_tmp(1) + (h/4._wp)*(mydMvdt_tmp(1) + mydMvdt_tmp(2)) - call s_advance_EL(myR_tmp(3), myV_tmp(3), myPb_tmp(3), myMv_tmp(3), & - bub_id, fmass_g, fbeta_c, fbeta_t, mydPbdt_tmp(3), mydMvdt_tmp(3)) + call s_advance_EL(myR_tmp(3), myV_tmp(3), myPb_tmp(3), myMv_tmp(3), bub_id, fmass_g, fbeta_c, fbeta_t, & + & mydPbdt_tmp(3), mydMvdt_tmp(3)) end if - myA_tmp(3) = f_rddot(fRho, fP, myR_tmp(3), myV_tmp(3), fR0, & - myPb_tmp(3), mydPbdt_tmp(3), alf, fntait, fBtait, & - f_bub_adv_src, f_divu, & - fCson) + myA_tmp(3) = f_rddot(fRho, fP, myR_tmp(3), myV_tmp(3), fR0, myPb_tmp(3), mydPbdt_tmp(3), alf, fntait, fBtait, & + & f_bub_adv_src, f_divu, fCson) ! Stage 3 myR_tmp(4) = myR_tmp(1) + (h/6._wp)*(myV_tmp(1) + myV_tmp(2) + 4._wp*myV_tmp(3)) @@ -767,56 +673,47 @@ contains if (bubbles_lagrange) then myPb_tmp(4) = myPb_tmp(1) + (h/6._wp)*(mydPbdt_tmp(1) + mydPbdt_tmp(2) + 4._wp*mydPbdt_tmp(3)) myMv_tmp(4) = myMv_tmp(1) + (h/6._wp)*(mydMvdt_tmp(1) + mydMvdt_tmp(2) + 4._wp*mydMvdt_tmp(3)) - call s_advance_EL(myR_tmp(4), myV_tmp(4), myPb_tmp(4), myMv_tmp(4), & - bub_id, fmass_g, fbeta_c, fbeta_t, mydPbdt_tmp(4), mydMvdt_tmp(4)) + call s_advance_EL(myR_tmp(4), myV_tmp(4), myPb_tmp(4), myMv_tmp(4), bub_id, fmass_g, fbeta_c, fbeta_t, & + & mydPbdt_tmp(4), mydMvdt_tmp(4)) end if - myA_tmp(4) = f_rddot(fRho, fP, myR_tmp(4), myV_tmp(4), fR0, & - myPb_tmp(4), mydPbdt_tmp(4), alf, fntait, fBtait, & - f_bub_adv_src, f_divu, & - fCson) + myA_tmp(4) = f_rddot(fRho, fP, myR_tmp(4), myV_tmp(4), fR0, myPb_tmp(4), mydPbdt_tmp(4), alf, fntait, fBtait, & + & f_bub_adv_src, f_divu, fCson) ! Estimate error - err_R = (-5._wp*h/24._wp)*(myV_tmp(2) + myV_tmp(3) - 2._wp*myV_tmp(4)) & - /max(abs(myR_tmp(1)), abs(myR_tmp(4))) - err_V = (-5._wp*h/24._wp)*(myA_tmp(2) + myA_tmp(3) - 2._wp*myA_tmp(4)) & - /max(abs(myV_tmp(1)), abs(myV_tmp(4))) + err_R = (-5._wp*h/24._wp)*(myV_tmp(2) + myV_tmp(3) - 2._wp*myV_tmp(4))/max(abs(myR_tmp(1)), abs(myR_tmp(4))) + err_V = (-5._wp*h/24._wp)*(myA_tmp(2) + myA_tmp(3) - 2._wp*myA_tmp(4))/max(abs(myV_tmp(1)), abs(myV_tmp(4))) ! Error correction for non-oscillating bubbles if (max(abs(myV_tmp(1)), abs(myV_tmp(4))) < 1.e-12_wp) then err_V = 0._wp end if - if (bubbles_lagrange .and. f_approx_equal(myA_tmp(1), 0._wp) .and. f_approx_equal(myA_tmp(2), 0._wp) .and. & - f_approx_equal(myA_tmp(3), 0._wp) .and. f_approx_equal(myA_tmp(4), 0._wp)) then + if (bubbles_lagrange .and. f_approx_equal(myA_tmp(1), 0._wp) .and. f_approx_equal(myA_tmp(2), & + & 0._wp) .and. f_approx_equal(myA_tmp(3), 0._wp) .and. f_approx_equal(myA_tmp(4), 0._wp)) then err_V = 0._wp end if err = sqrt((err_R**2._wp + err_V**2._wp)/2._wp) - end subroutine s_advance_substep - - !> Changes of pressure and vapor mass in the lagrange bubbles. - !! @param fR_tmp Bubble radius - !! @param fV_tmp Bubble radial velocity - !! @param fPb_tmp Internal bubble pressure - !! @param fMv_tmp Mass of vapor in the bubble - !! @param bub_id Bubble identifier - !! @param fmass_g Current mass of gas - !! @param fbeta_c Mass transfer coefficient - !! @param fbeta_t Heat transfer coefficient - !! @param fdPbdt_tmp Rate of change of the internal bubble pressure - !! @param advance_EL Rate of change of the mass of vapor in the bubble - elemental subroutine s_advance_EL(fR_tmp, fV_tmp, fPb_tmp, fMv_tmp, bub_id, & - fmass_g, fbeta_c, fbeta_t, fdPbdt_tmp, advance_EL) + !> Changes of pressure and vapor mass in the lagrange bubbles. + !! @param fR_tmp Bubble radius + !! @param fV_tmp Bubble radial velocity + !! @param fPb_tmp Internal bubble pressure + !! @param fMv_tmp Mass of vapor in the bubble + !! @param bub_id Bubble identifier + !! @param fmass_g Current mass of gas + !! @param fbeta_c Mass transfer coefficient + !! @param fbeta_t Heat transfer coefficient + !! @param fdPbdt_tmp Rate of change of the internal bubble pressure + !! @param advance_EL Rate of change of the mass of vapor in the bubble + elemental subroutine s_advance_EL(fR_tmp, fV_tmp, fPb_tmp, fMv_tmp, bub_id, fmass_g, fbeta_c, fbeta_t, fdPbdt_tmp, advance_EL) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(IN) :: fR_tmp, fV_tmp, fPb_tmp, fMv_tmp - real(wp), intent(IN) :: fmass_g, fbeta_c, fbeta_t - integer, intent(IN) :: bub_id - real(wp), intent(INOUT) :: fdPbdt_tmp - real(wp), intent(out) :: advance_EL - real(wp) :: fVapFlux, myR_m, mygamma_m + real(wp), intent(in) :: fR_tmp, fV_tmp, fPb_tmp, fMv_tmp + real(wp), intent(in) :: fmass_g, fbeta_c, fbeta_t + integer, intent(in) :: bub_id + real(wp), intent(inout) :: fdPbdt_tmp + real(wp), intent(out) :: advance_EL + real(wp) :: fVapFlux, myR_m, mygamma_m call s_vflux(fR_tmp, fV_tmp, fPb_tmp, fMv_tmp, bub_id, fVapFlux, fmass_g, fbeta_c, myR_m, mygamma_m) fdPbdt_tmp = f_bpres_dot(fVapFlux, fR_tmp, fV_tmp, fPb_tmp, fMv_tmp, bub_id, fbeta_t, myR_m, mygamma_m) advance_EL = 4._wp*pi*fR_tmp**2._wp*fVapFlux - end subroutine s_advance_EL - end module m_bubbles diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index dad03d3f87..6a5131ad62 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -6,7 +6,6 @@ !> @brief Computes ensemble-averaged (Euler--Euler) bubble source terms for radius, velocity, pressure, and mass transfer module m_bubbles_EE - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -19,21 +18,19 @@ module m_bubbles_EE implicit none - real(wp), allocatable, dimension(:, :, :) :: bub_adv_src - real(wp), allocatable, dimension(:, :, :, :) :: bub_r_src, bub_v_src, bub_p_src, bub_m_src - $:GPU_DECLARE(create='[bub_adv_src,bub_r_src,bub_v_src,bub_p_src,bub_m_src]') + real(wp), allocatable, dimension(:,:,:) :: bub_adv_src + real(wp), allocatable, dimension(:,:,:,:) :: bub_r_src, bub_v_src, bub_p_src, bub_m_src + $:GPU_DECLARE(create='[bub_adv_src, bub_r_src, bub_v_src, bub_p_src, bub_m_src]') type(scalar_field) :: divu !< matrix for div(u) $:GPU_DECLARE(create='[divu]') integer, allocatable, dimension(:) :: rs, vs, ms, ps - $:GPU_DECLARE(create='[rs,vs,ms,ps]') - + $:GPU_DECLARE(create='[rs, vs, ms, ps]') contains !> @brief Allocates and initializes arrays for the Euler-Euler bubble model. impure subroutine s_initialize_bubbles_EE_module - integer :: l @:ALLOCATE(rs(1:nb)) @@ -66,17 +63,15 @@ contains @:ALLOCATE(bub_m_src(0:m, 0:n, 0:p, 1:nb)) if (adap_dt .and. f_is_default(adap_dt_tol)) adap_dt_tol = dflt_adap_dt_tol - end subroutine s_initialize_bubbles_EE_module - !> @brief Computes the bubble volume fraction alpha from the bubble number density. !! @param q_cons_vf is the conservative variable subroutine s_comp_alpha_from_n(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(wp) :: nR3bar - integer(wp) :: i, j, k, l + real(wp) :: nR3bar + integer(wp) :: i, j, k, l - $:GPU_PARALLEL_LOOP(private='[i,j,k,l,nR3bar]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l, nR3bar]', collapse=3) do l = 0, p do k = 0, n do j = 0, m @@ -90,104 +85,82 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_comp_alpha_from_n - - !> Compute the right-hand side for Euler-Euler bubble transport + !> Compute the right-hand side for Euler-Euler bubble transport !! @param idir Direction index !! @param q_prim_vf Primitive variables subroutine s_compute_bubbles_EE_rhs(idir, q_prim_vf, divu_in) - - integer, intent(in) :: idir + integer, intent(in) :: idir type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), intent(inout) :: divu_in !< matrix for div(u) - - integer :: j, k, l + type(scalar_field), intent(inout) :: divu_in !< matrix for div(u) + integer :: j, k, l if (idir == 1) then - if (.not. qbmm) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m divu_in%sf(j, k, l) = 0._wp - divu_in%sf(j, k, l) = & - 5.e-1_wp/dx(j)*(q_prim_vf(contxe + idir)%sf(j + 1, k, l) - & - q_prim_vf(contxe + idir)%sf(j - 1, k, l)) - + divu_in%sf(j, k, l) = 5.e-1_wp/dx(j)*(q_prim_vf(contxe + idir)%sf(j + 1, k, & + & l) - q_prim_vf(contxe + idir)%sf(j - 1, k, l)) end do end do end do $:END_GPU_PARALLEL_LOOP() end if - - elseif (idir == 2) then - - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + else if (idir == 2) then + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - divu_in%sf(j, k, l) = divu_in%sf(j, k, l) + & - 5.e-1_wp/dy(k)*(q_prim_vf(contxe + idir)%sf(j, k + 1, l) - & - q_prim_vf(contxe + idir)%sf(j, k - 1, l)) - + divu_in%sf(j, k, l) = divu_in%sf(j, k, l) + 5.e-1_wp/dy(k)*(q_prim_vf(contxe + idir)%sf(j, k + 1, & + & l) - q_prim_vf(contxe + idir)%sf(j, k - 1, l)) end do end do end do $:END_GPU_PARALLEL_LOOP() - - elseif (idir == 3) then - - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + else if (idir == 3) then + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - divu_in%sf(j, k, l) = divu_in%sf(j, k, l) + & - 5.e-1_wp/dz(l)*(q_prim_vf(contxe + idir)%sf(j, k, l + 1) - & - q_prim_vf(contxe + idir)%sf(j, k, l - 1)) - + divu_in%sf(j, k, l) = divu_in%sf(j, k, l) + 5.e-1_wp/dz(l)*(q_prim_vf(contxe + idir)%sf(j, k, & + & l + 1) - q_prim_vf(contxe + idir)%sf(j, k, l - 1)) end do end do end do $:END_GPU_PARALLEL_LOOP() - end if - end subroutine s_compute_bubbles_EE_rhs - - !> The purpose of this procedure is to compute the source terms - !! that are needed for the bubble modeling - !! @param q_prim_vf Primitive variables - !! @param q_cons_vf Conservative variables - !! @param rhs_vf Right-hand side variables + !> The purpose of this procedure is to compute the source terms that are needed for the bubble modeling + !! @param q_prim_vf Primitive variables + !! @param q_cons_vf Conservative variables + !! @param rhs_vf Right-hand side variables impure subroutine s_compute_bubble_EE_source(q_cons_vf, q_prim_vf, rhs_vf, divu_in) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - type(scalar_field), intent(in) :: divu_in !< matrix for div(u) - - real(wp) :: rddot - real(wp) :: pb_local, mv_local, vflux, pbdot - real(wp) :: n_tait, B_tait + type(scalar_field), intent(in) :: divu_in !< matrix for div(u) + real(wp) :: rddot + real(wp) :: pb_local, mv_local, vflux, pbdot + real(wp) :: n_tait, B_tait #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: Rtmp, Vtmp real(wp), dimension(3) :: myalpha, myalpha_rho #:else - real(wp), dimension(nb) :: Rtmp, Vtmp + real(wp), dimension(nb) :: Rtmp, Vtmp real(wp), dimension(num_fluids) :: myalpha, myalpha_rho #:endif real(wp) :: myR, myV, alf, myP, myRho, R2Vav, R3 real(wp) :: nbub !< Bubble number density real(wp) :: my_divu - - integer :: i, j, k, l, q, ii !< Loop variables - - integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached - integer :: dmBub_id !< Dummy variables for unified subgrid bubble subroutines + integer :: i, j, k, l, q, ii !< Loop variables + integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached + integer :: dmBub_id !< Dummy variables for unified subgrid bubble subroutines real(wp) :: dmMass_v, dmMass_n, dmBeta_c, dmBeta_t, dmCson - $:GPU_PARALLEL_LOOP(private='[j,k,l,q]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l, q]', collapse=3) do l = 0, p do k = 0, n do j = 0, m @@ -206,13 +179,12 @@ contains $:END_GPU_PARALLEL_LOOP() adap_dt_stop_max = 0 - $:GPU_PARALLEL_LOOP(private='[j,k,l,Rtmp, Vtmp, myalpha_rho, myalpha, myR, myV, alf, myP, myRho, R2Vav, R3, nbub, pb_local, mv_local, vflux, pbdot, rddot, n_tait, B_tait, my_divu]', collapse=3, & - & reduction='[[adap_dt_stop_max]]', reductionOp='[MAX]', & - & copy='[adap_dt_stop_max]') + $:GPU_PARALLEL_LOOP(private='[j, k, l, Rtmp, Vtmp, myalpha_rho, myalpha, myR, myV, alf, myP, myRho, R2Vav, R3, nbub, & + & pb_local, mv_local, vflux, pbdot, rddot, n_tait, B_tait, my_divu]', collapse=3, & + & reduction = '[[adap_dt_stop_max]]', reductionOp = '[MAX]', copy = '[adap_dt_stop_max]') do l = 0, p do k = 0, n do j = 0, m - if (adv_n) then nbub = q_prim_vf(n_idx)%sf(j, k, l) else @@ -245,7 +217,6 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 1, nb - $:GPU_LOOP(parallelism='[seq]') do ii = 1, num_fluids myalpha_rho(ii) = q_cons_vf(ii)%sf(j, k, l) @@ -269,7 +240,7 @@ contains end do end if - n_tait = 1._wp/n_tait + 1._wp !make this the usual little 'gamma' + n_tait = 1._wp/n_tait + 1._wp ! make this the usual little 'gamma' B_tait = B_tait*(n_tait - 1)/n_tait ! make this the usual pi_inf myP = q_prim_vf(E_idx)%sf(j, k, l) @@ -302,22 +273,17 @@ contains if (adap_dt) then adap_dt_stop = 0 - call s_advance_step(myRho, myP, myR, myV, R0(q), & - pb_local, pbdot, alf, n_tait, B_tait, & - bub_adv_src(j, k, l), divu_in%sf(j, k, l), & - dmBub_id, dmMass_v, dmMass_n, dmBeta_c, & - dmBeta_t, dmCson, adap_dt_stop) + call s_advance_step(myRho, myP, myR, myV, R0(q), pb_local, pbdot, alf, n_tait, B_tait, & + & bub_adv_src(j, k, l), divu_in%sf(j, k, l), dmBub_id, dmMass_v, dmMass_n, & + & dmBeta_c, dmBeta_t, dmCson, adap_dt_stop) q_cons_vf(rs(q))%sf(j, k, l) = nbub*myR q_cons_vf(vs(q))%sf(j, k, l) = nbub*myV adap_dt_stop_max = max(adap_dt_stop_max, adap_dt_stop) - else - rddot = f_rddot(myRho, myP, myR, myV, R0(q), & - pb_local, pbdot, alf, n_tait, B_tait, & - bub_adv_src(j, k, l), divu_in%sf(j, k, l), & - dmCson) + rddot = f_rddot(myRho, myP, myR, myV, R0(q), pb_local, pbdot, alf, n_tait, B_tait, bub_adv_src(j, & + & k, l), divu_in%sf(j, k, l), dmCson) bub_v_src(j, k, l, q) = nbub*rddot bub_r_src(j, k, l, q) = q_cons_vf(vs(q))%sf(j, k, l) end if @@ -331,13 +297,12 @@ contains if (adap_dt .and. adap_dt_stop_max > 0) call s_mpi_abort("Adaptive time stepping failed to converge.") if (.not. adap_dt) then - $:GPU_PARALLEL_LOOP(private='[i,k,l,q]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, k, l, q]', collapse=3) do l = 0, p do q = 0, n do i = 0, m rhs_vf(alf_idx)%sf(i, q, l) = rhs_vf(alf_idx)%sf(i, q, l) + bub_adv_src(i, q, l) - if (num_fluids > 1) rhs_vf(advxb)%sf(i, q, l) = & - rhs_vf(advxb)%sf(i, q, l) - bub_adv_src(i, q, l) + if (num_fluids > 1) rhs_vf(advxb)%sf(i, q, l) = rhs_vf(advxb)%sf(i, q, l) - bub_adv_src(i, q, l) $:GPU_LOOP(parallelism='[seq]') do k = 1, nb rhs_vf(rs(k))%sf(i, q, l) = rhs_vf(rs(k))%sf(i, q, l) + bub_r_src(i, q, l, k) @@ -353,5 +318,4 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_compute_bubble_EE_source - end module m_bubbles_EE diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 4ae590a4b8..09a672ba4c 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -6,7 +6,6 @@ !> @brief Tracks Lagrangian bubbles and couples their dynamics to the Eulerian flow via volume averaging module m_bubbles_EL - use m_global_parameters !< Definitions of the global parameters use m_mpi_proxy !< Message passing interface (MPI) module proxy @@ -29,11 +28,11 @@ module m_bubbles_EL implicit none - !(nBub) - integer, allocatable, dimension(:, :) :: lag_id !< Global and local IDs - real(wp), allocatable, dimension(:) :: bub_R0 !< Initial bubble radius - real(wp), allocatable, dimension(:) :: Rmax_stats !< Maximum radius - real(wp), allocatable, dimension(:) :: Rmin_stats !< Minimum radius + ! (nBub) + integer, allocatable, dimension(:,:) :: lag_id !< Global and local IDs + real(wp), allocatable, dimension(:) :: bub_R0 !< Initial bubble radius + real(wp), allocatable, dimension(:) :: Rmax_stats !< Maximum radius + real(wp), allocatable, dimension(:) :: Rmin_stats !< Minimum radius $:GPU_DECLARE(create='[lag_id, bub_R0, Rmax_stats, Rmin_stats]') real(wp), allocatable, dimension(:) :: gas_mg !< Bubble's gas mass @@ -42,48 +41,45 @@ module m_bubbles_EL real(wp), allocatable, dimension(:) :: bub_dphidt !< subgrid velocity potential (Maeda & Colonius, 2018) $:GPU_DECLARE(create='[gas_mg, gas_betaT, gas_betaC, bub_dphidt]') - !(nBub, 1 -> actual val or 2 -> temp val) - real(wp), allocatable, dimension(:, :) :: gas_p !< Pressure in the bubble - real(wp), allocatable, dimension(:, :) :: gas_mv !< Vapor mass in the bubble - real(wp), allocatable, dimension(:, :) :: intfc_rad !< Bubble radius - real(wp), allocatable, dimension(:, :) :: intfc_vel !< Velocity of the bubble interface + ! (nBub, 1 -> actual val or 2 -> temp val) + real(wp), allocatable, dimension(:,:) :: gas_p !< Pressure in the bubble + real(wp), allocatable, dimension(:,:) :: gas_mv !< Vapor mass in the bubble + real(wp), allocatable, dimension(:,:) :: intfc_rad !< Bubble radius + real(wp), allocatable, dimension(:,:) :: intfc_vel !< Velocity of the bubble interface $:GPU_DECLARE(create='[gas_p, gas_mv, intfc_rad, intfc_vel]') - !(nBub, 1-> x or 2->y or 3 ->z, 1 -> actual or 2 -> temporal val) - real(wp), allocatable, dimension(:, :, :) :: mtn_pos !< Bubble's position - real(wp), allocatable, dimension(:, :, :) :: mtn_posPrev !< Bubble's previous position - real(wp), allocatable, dimension(:, :, :) :: mtn_vel !< Bubble's velocity - real(wp), allocatable, dimension(:, :, :) :: mtn_s !< Bubble's computational cell position in real format + ! (nBub, 1-> x or 2->y or 3 ->z, 1 -> actual or 2 -> temporal val) + real(wp), allocatable, dimension(:,:,:) :: mtn_pos !< Bubble's position + real(wp), allocatable, dimension(:,:,:) :: mtn_posPrev !< Bubble's previous position + real(wp), allocatable, dimension(:,:,:) :: mtn_vel !< Bubble's velocity + real(wp), allocatable, dimension(:,:,:) :: mtn_s !< Bubble's computational cell position in real format $:GPU_DECLARE(create='[mtn_pos, mtn_posPrev, mtn_vel, mtn_s]') - !(nBub, 1-> x or 2->y or 3 ->z, time-stage) - real(wp), allocatable, dimension(:, :) :: intfc_draddt !< Time derivative of bubble's radius - real(wp), allocatable, dimension(:, :) :: intfc_dveldt !< Time derivative of bubble's interface velocity - real(wp), allocatable, dimension(:, :) :: gas_dpdt !< Time derivative of gas pressure - real(wp), allocatable, dimension(:, :) :: gas_dmvdt !< Time derivative of the vapor mass in the bubble - real(wp), allocatable, dimension(:, :, :) :: mtn_dposdt !< Time derivative of the bubble's position - real(wp), allocatable, dimension(:, :, :) :: mtn_dveldt !< Time derivative of the bubble's velocity + ! (nBub, 1-> x or 2->y or 3 ->z, time-stage) + real(wp), allocatable, dimension(:,:) :: intfc_draddt !< Time derivative of bubble's radius + real(wp), allocatable, dimension(:,:) :: intfc_dveldt !< Time derivative of bubble's interface velocity + real(wp), allocatable, dimension(:,:) :: gas_dpdt !< Time derivative of gas pressure + real(wp), allocatable, dimension(:,:) :: gas_dmvdt !< Time derivative of the vapor mass in the bubble + real(wp), allocatable, dimension(:,:,:) :: mtn_dposdt !< Time derivative of the bubble's position + real(wp), allocatable, dimension(:,:,:) :: mtn_dveldt !< Time derivative of the bubble's velocity $:GPU_DECLARE(create='[intfc_draddt, intfc_dveldt, gas_dpdt, gas_dmvdt, mtn_dposdt, mtn_dveldt]') integer, private :: lag_num_ts !< Number of time stages in the time-stepping scheme $:GPU_DECLARE(create='[lag_num_ts]') - integer :: nBubs !< Number of bubbles in the local domain + integer :: nBubs !< Number of bubbles in the local domain real(wp) :: Rmax_glb, Rmin_glb !< Maximum and minimum bubbe size in the local domain !< Projection of the lagrangian particles in the Eulerian framework type(scalar_field), dimension(:), allocatable :: q_beta - integer :: q_beta_idx !< Size of the q_beta vector field - - $:GPU_DECLARE(create='[nBubs,Rmax_glb,Rmin_glb,q_beta,q_beta_idx]') + integer :: q_beta_idx !< Size of the q_beta vector field + $:GPU_DECLARE(create='[nBubs, Rmax_glb, Rmin_glb, q_beta, q_beta_idx]') contains !> Initializes the lagrangian subgrid bubble solver !! @param q_cons_vf Initial conservative variables impure subroutine s_initialize_bubbles_EL_module(q_cons_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - - integer :: nBubs_glb, i + integer :: nBubs_glb, i ! Setting number of time-stages for selected time-stepping scheme lag_num_ts = time_stepper @@ -92,11 +88,11 @@ contains if (lag_params%solver_approach == 1) then ! One-way coupling q_beta_idx = 3 - elseif (lag_params%solver_approach == 2) then + else if (lag_params%solver_approach == 2) then ! Two-way coupling q_beta_idx = 4 if (p == 0) then - !Subgrid noise model for 2D approximation + ! Subgrid noise model for 2D approximation q_beta_idx = 6 end if else @@ -108,9 +104,7 @@ contains @:ALLOCATE(q_beta(1:q_beta_idx)) do i = 1, q_beta_idx - @:ALLOCATE(q_beta(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_beta(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do do i = 1, q_beta_idx @@ -147,22 +141,17 @@ contains ! Starting bubbles call s_read_input_bubbles(q_cons_vf) - end subroutine s_initialize_bubbles_EL_module - !> The purpose of this procedure is to obtain the initial bubbles' information !! @param q_cons_vf Conservative variables impure subroutine s_read_input_bubbles(q_cons_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - - real(wp), dimension(8) :: inputBubble - real(wp) :: qtime - integer :: id, bub_id, save_count - integer :: i, ios - logical :: file_exist, indomain - - character(LEN=path_len + 2*name_len) :: path_D_dir !< + real(wp), dimension(8) :: inputBubble + real(wp) :: qtime + integer :: id, bub_id, save_count + integer :: i, ios + logical :: file_exist, indomain + character(LEN=path_len + 2*name_len) :: path_D_dir !< ! Initialize number of particles bub_id = 0 @@ -193,9 +182,9 @@ contains if (indomain) then bub_id = bub_id + 1 call s_add_bubbles(inputBubble, q_cons_vf, bub_id) - lag_id(bub_id, 1) = id !global ID - lag_id(bub_id, 2) = bub_id !local ID - nBubs = bub_id ! local number of bubbles + lag_id(bub_id, 1) = id ! global ID + lag_id(bub_id, 2) = bub_id ! local ID + nBubs = bub_id ! local number of bubbles end if end do close (94) @@ -212,18 +201,16 @@ contains $:GPU_UPDATE(device='[bubbles_lagrange, lag_params]') $:GPU_UPDATE(device='[lag_id,bub_R0,Rmax_stats,Rmin_stats,gas_mg, & - & gas_betaT,gas_betaC,bub_dphidt,gas_p,gas_mv, & - & intfc_rad,intfc_vel,mtn_pos,mtn_posPrev,mtn_vel, & - & mtn_s,intfc_draddt,intfc_dveldt,gas_dpdt,gas_dmvdt, & - & mtn_dposdt,mtn_dveldt,nBubs]') + & gas_betaT, gas_betaC, bub_dphidt, gas_p, gas_mv, intfc_rad, intfc_vel, mtn_pos, mtn_posPrev, mtn_vel, mtn_s, & + & intfc_draddt, intfc_dveldt, gas_dpdt, gas_dmvdt, mtn_dposdt, mtn_dveldt, nBubs]') Rmax_glb = min(dflt_real, -dflt_real) Rmin_glb = max(dflt_real, -dflt_real) $:GPU_UPDATE(device='[Rmax_glb, Rmin_glb]') - $:GPU_UPDATE(device='[dx,dy,dz,x_cb,x_cc,y_cb,y_cc,z_cb,z_cc]') + $:GPU_UPDATE(device='[dx, dy, dz, x_cb, x_cc, y_cb, y_cc, z_cb, z_cc]') - !Populate temporal variables + ! Populate temporal variables call s_transfer_data_to_tmp() call s_smear_voidfraction() @@ -231,31 +218,27 @@ contains if (save_count == 0) then ! Create ./D directory - write (path_D_dir, '(A,I0,A,I0)') trim(case_dir)//'/D' + write (path_D_dir, '(A,I0,A,I0)') trim(case_dir) // '/D' call my_inquire(path_D_dir, file_exist) if (.not. file_exist) call s_create_directory(trim(path_D_dir)) call s_write_restart_lag_bubbles(save_count) ! Needed for post_processing call s_write_void_evol(qtime) end if - end subroutine s_read_input_bubbles - !> The purpose of this procedure is to obtain the information of the bubbles when starting fresh !! @param inputBubble Bubble information !! @param q_cons_vf Conservative variables !! @param bub_id Local id of the bubble impure subroutine s_add_bubbles(inputBubble, q_cons_vf, bub_id) - type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(wp), dimension(8), intent(in) :: inputBubble - integer, intent(in) :: bub_id - integer :: i - - real(wp) :: pliq, volparticle, concvap, totalmass, kparticle, cpparticle - real(wp) :: omegaN_local, PeG, PeT, rhol, pcrit, qv, gamma, pi_inf, dynP - integer, dimension(3) :: cell - real(wp), dimension(2) :: Re - real(wp) :: massflag, heatflag, Re_trans, Im_trans + real(wp), dimension(8), intent(in) :: inputBubble + integer, intent(in) :: bub_id + integer :: i + real(wp) :: pliq, volparticle, concvap, totalmass, kparticle, cpparticle + real(wp) :: omegaN_local, PeG, PeT, rhol, pcrit, qv, gamma, pi_inf, dynP + integer, dimension(3) :: cell + real(wp), dimension(2) :: Re + real(wp) :: massflag, heatflag, Re_trans, Im_trans massflag = 0._wp heatflag = 0._wp @@ -273,9 +256,8 @@ contains mtn_vel(bub_id, 1:3, 1) = inputBubble(4:6) if (cyl_coord .and. p == 0) then - mtn_pos(bub_id, 2, 1) = sqrt(mtn_pos(bub_id, 2, 1)**2._wp + & - mtn_pos(bub_id, 3, 1)**2._wp) - !Storing azimuthal angle (-Pi to Pi)) into the third coordinate variable + mtn_pos(bub_id, 2, 1) = sqrt(mtn_pos(bub_id, 2, 1)**2._wp + mtn_pos(bub_id, 3, 1)**2._wp) + ! Storing azimuthal angle (-Pi to Pi)) into the third coordinate variable mtn_pos(bub_id, 3, 1) = atan2(inputBubble(3), inputBubble(2)) mtn_posPrev(bub_id, 1:3, 1) = mtn_pos(bub_id, 1:3, 1) end if @@ -284,29 +266,30 @@ contains call s_locate_cell(mtn_pos(bub_id, 1:3, 1), cell, mtn_s(bub_id, 1:3, 1)) ! Check if the bubble is located in the ghost cell of a symmetric, or wall boundary - if ((any(bc_x%beg == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, BC_NO_SLIP_WALL/)) .and. cell(1) < 0) .or. & - (any(bc_x%end == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, BC_NO_SLIP_WALL/)) .and. cell(1) > m) .or. & - (any(bc_y%beg == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, BC_NO_SLIP_WALL/)) .and. cell(2) < 0) .or. & - (any(bc_y%end == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, BC_NO_SLIP_WALL/)) .and. cell(2) > n)) then + if ((any(bc_x%beg == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, & + & BC_NO_SLIP_WALL/)) .and. cell(1) < 0) .or. (any(bc_x%end == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, & + & BC_NO_SLIP_WALL/)) .and. cell(1) > m) .or. (any(bc_y%beg == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, & + & BC_NO_SLIP_WALL/)) .and. cell(2) < 0) .or. (any(bc_y%end == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, & + & BC_NO_SLIP_WALL/)) .and. cell(2) > n)) then call s_mpi_abort("Lagrange bubble is in the ghost cells of a symmetric or wall boundary.") end if if (p > 0) then - if ((any(bc_z%beg == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, BC_NO_SLIP_WALL/)) .and. cell(3) < 0) .or. & - (any(bc_z%end == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, BC_NO_SLIP_WALL/)) .and. cell(3) > p)) then + if ((any(bc_z%beg == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, & + & BC_NO_SLIP_WALL/)) .and. cell(3) < 0) .or. (any(bc_z%end == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, & + & BC_NO_SLIP_WALL/)) .and. cell(3) > p)) then call s_mpi_abort("Lagrange bubble is in the ghost cells of a symmetric or wall boundary.") end if end if - call s_convert_to_mixture_variables(q_cons_vf, cell(1), cell(2), cell(3), & - rhol, gamma, pi_inf, qv, Re) + call s_convert_to_mixture_variables(q_cons_vf, cell(1), cell(2), cell(3), rhol, gamma, pi_inf, qv, Re) dynP = 0._wp do i = 1, num_dims dynP = dynP + 0.5_wp*q_cons_vf(contxe + i)%sf(cell(1), cell(2), cell(3))**2/rhol end do pliq = (q_cons_vf(E_idx)%sf(cell(1), cell(2), cell(3)) - dynP - pi_inf)/gamma - if (pliq < 0) print *, "Negative pressure", proc_rank, & - q_cons_vf(E_idx)%sf(cell(1), cell(2), cell(3)), pi_inf, gamma, pliq, cell, dynP + if (pliq < 0) print *, "Negative pressure", proc_rank, q_cons_vf(E_idx)%sf(cell(1), cell(2), cell(3)), pi_inf, gamma, & + & pliq, cell, dynP ! Initial particle pressure gas_p(bub_id, 1) = pliq + 2._wp*(1._wp/Web)/bub_R0(bub_id) @@ -349,52 +332,44 @@ contains if (gas_mg(bub_id) <= 0._wp) then call s_mpi_abort("Negative gas mass in the bubble, check if the bubble is in the domain.") end if - end subroutine s_add_bubbles - !> The purpose of this procedure is to obtain the information of the bubbles from a restart point. !! @param bub_id Local ID of the particle !! @param save_count File identifier impure subroutine s_restart_bubbles(bub_id, save_count) - - integer, intent(inout) :: bub_id, save_count - + integer, intent(inout) :: bub_id, save_count character(LEN=path_len + 2*name_len) :: file_loc - real(wp) :: file_time, file_dt - integer :: file_num_procs, file_tot_part, tot_part + real(wp) :: file_time, file_dt + integer :: file_num_procs, file_tot_part, tot_part #ifdef MFC_MPI - real(wp), dimension(20) :: inputvals - integer, dimension(MPI_STATUS_SIZE) :: status - integer(kind=MPI_OFFSET_KIND) :: disp - integer :: view - - integer, dimension(3) :: cell - logical :: indomain, particle_file, file_exist - - integer, dimension(2) :: gsizes, lsizes, start_idx_part - integer :: ifile, ierr, tot_data, id - integer :: i - - integer, dimension(:), allocatable :: proc_bubble_counts + real(wp), dimension(20) :: inputvals + integer, dimension(MPI_STATUS_SIZE) :: status + integer(kind=MPI_OFFSET_KIND) :: disp + integer :: view + integer, dimension(3) :: cell + logical :: indomain, particle_file, file_exist + integer, dimension(2) :: gsizes, lsizes, start_idx_part + integer :: ifile, ierr, tot_data, id + integer :: i + integer, dimension(:), allocatable :: proc_bubble_counts real(wp), dimension(1:1, 1:lag_io_vars) :: dummy dummy = 0._wp ! Construct file path write (file_loc, '(A,I0,A)') 'lag_bubbles_', save_count, '.dat' - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) ! Check if file exists inquire (FILE=trim(file_loc), EXIST=file_exist) if (.not. file_exist) then - call s_mpi_abort('Restart file '//trim(file_loc)//' does not exist!') + call s_mpi_abort('Restart file ' // trim(file_loc) // ' does not exist!') end if if (.not. parallel_io) return if (proc_rank == 0) then - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) call MPI_FILE_READ(ifile, file_tot_part, 1, MPI_INTEGER, status, ierr) call MPI_FILE_READ(ifile, file_time, 1, mpi_p, status, ierr) @@ -412,12 +387,10 @@ contains allocate (proc_bubble_counts(file_num_procs)) if (proc_rank == 0) then - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) ! Skip to processor counts position - disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs), & - MPI_OFFSET_KIND) + disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs), MPI_OFFSET_KIND) call MPI_FILE_SEEK(ifile, disp, MPI_SEEK_SET, ierr) call MPI_FILE_READ(ifile, proc_bubble_counts, file_num_procs, MPI_INTEGER, status, ierr) @@ -445,23 +418,19 @@ contains gsizes(2) = lag_io_vars if (bub_id > 0) then - allocate (MPI_IO_DATA_lag_bubbles(bub_id, 1:lag_io_vars)) - call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, & - MPI_ORDER_FORTRAN, mpi_p, view, ierr) + call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, MPI_ORDER_FORTRAN, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) ! Skip extended header - disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) + & - file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) - call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lag_bubbles, & - lag_io_vars*bub_id, mpi_p, status, ierr) + call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lag_bubbles, lag_io_vars*bub_id, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) call MPI_TYPE_FREE(view, ierr) @@ -489,19 +458,17 @@ contains end do deallocate (MPI_IO_DATA_lag_bubbles) - else nBubs = 0 call MPI_TYPE_CONTIGUOUS(0, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) ! Skip extended header - disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) + & - file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -517,42 +484,36 @@ contains deallocate (proc_bubble_counts) #endif - end subroutine s_restart_bubbles - - !> Contains the bubble dynamics subroutines. + !> Contains the bubble dynamics subroutines. !! @param q_prim_vf Primitive variables !! @param stage Current stage in the time-stepper algorithm subroutine s_compute_bubble_EL_dynamics(q_prim_vf, stage) - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: stage - - real(wp) :: myVapFlux - real(wp) :: preterm1, term2, paux, pint, Romega, term1_fac - real(wp) :: myR_m, mygamma_m, myPb, myMass_n, myMass_v - real(wp) :: myR, myV, myBeta_c, myBeta_t, myR0, myPbdot, myMvdot - real(wp) :: myPinf, aux1, aux2, myCson, myRho - real(wp) :: gamma, pi_inf, qv + integer, intent(in) :: stage + real(wp) :: myVapFlux + real(wp) :: preterm1, term2, paux, pint, Romega, term1_fac + real(wp) :: myR_m, mygamma_m, myPb, myMass_n, myMass_v + real(wp) :: myR, myV, myBeta_c, myBeta_t, myR0, myPbdot, myMvdot + real(wp) :: myPinf, aux1, aux2, myCson, myRho + real(wp) :: gamma, pi_inf, qv #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: myalpha_rho, myalpha #:else real(wp), dimension(num_fluids) :: myalpha_rho, myalpha #:endif real(wp), dimension(2) :: Re - integer, dimension(3) :: cell - - integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached - real(wp) :: dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu !< Dummy variables for unified subgrid bubble subroutines - - integer :: i, k, l + integer, dimension(3) :: cell + integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached + real(wp) :: dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu !< Dummy variables for unified subgrid bubble subroutines + integer :: i, k, l call nvtxStartRange("LAGRANGE-BUBBLE-DYNAMICS") ! Subgrid p_inf model based on Maeda and Colonius (2018). if (lag_params%pressure_corrector) then ! Calculate velocity potentials (valid for one bubble per cell) - $:GPU_PARALLEL_LOOP(private='[k,cell,paux,preterm1,term2,Romega,myR0,myR,myV,myPb,pint,term1_fac]') + $:GPU_PARALLEL_LOOP(private='[k, cell, paux, preterm1, term2, Romega, myR0, myR, myV, myPb, pint, term1_fac]') do k = 1, nBubs call s_get_pinf(k, q_prim_vf, 2, paux, cell, preterm1, term2, Romega) myR0 = bub_R0(k) @@ -574,9 +535,11 @@ contains ! Radial motion model adap_dt_stop_max = 0 - $:GPU_PARALLEL_LOOP(private='[k,i,myalpha_rho,myalpha,Re,cell,myVapFlux,preterm1, term2, paux, pint, Romega, term1_fac,myR_m, mygamma_m, myPb, myMass_n, myMass_v,myR, myV, myBeta_c, myBeta_t, myR0, myPbdot, myMvdot,myPinf, aux1, aux2, myCson, myRho,gamma,pi_inf,qv,dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu,adap_dt_stop]', & - & reduction='[[adap_dt_stop_max]]',reductionOp='[MAX]', & - & copy='[adap_dt_stop_max]',copyin='[stage]') + $:GPU_PARALLEL_LOOP(private='[k, i, myalpha_rho, myalpha, Re, cell, myVapFlux, preterm1, term2, paux, pint, Romega, & + & term1_fac, myR_m, mygamma_m, myPb, myMass_n, myMass_v, myR, myV, myBeta_c, myBeta_t, myR0, myPbdot, myMvdot, myPinf, & + & aux1, aux2, myCson, myRho, gamma, pi_inf, qv, dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu, & + & adap_dt_stop]', reduction='[[adap_dt_stop_max]]',reductionOp='[MAX]', & + & copy = '[adap_dt_stop_max]', copyin = '[stage]') do k = 1, nBubs ! Keller-Miksis model @@ -600,48 +563,39 @@ contains ! Obtain liquid density and computing speed of sound from pinf call s_compute_species_fraction(q_prim_vf, cell(1), cell(2), cell(3), myalpha_rho, myalpha) - call s_convert_species_to_mixture_variables_acc(myRho, gamma, pi_inf, qv, myalpha, & - myalpha_rho, Re) + call s_convert_species_to_mixture_variables_acc(myRho, gamma, pi_inf, qv, myalpha, myalpha_rho, Re) call s_compute_cson_from_pinf(q_prim_vf, myPinf, cell, myRho, gamma, pi_inf, myCson) ! Adaptive time stepping adap_dt_stop = 0 if (adap_dt) then - - call s_advance_step(myRho, myPinf, myR, myV, myR0, myPb, myPbdot, dmalf, & - dmntait, dmBtait, dm_bub_adv_src, dm_divu, & - k, myMass_v, myMass_n, myBeta_c, & - myBeta_t, myCson, adap_dt_stop) + call s_advance_step(myRho, myPinf, myR, myV, myR0, myPb, myPbdot, dmalf, dmntait, dmBtait, dm_bub_adv_src, & + & dm_divu, k, myMass_v, myMass_n, myBeta_c, myBeta_t, myCson, adap_dt_stop) ! Update bubble state intfc_rad(k, 1) = myR intfc_vel(k, 1) = myV gas_p(k, 1) = myPb gas_mv(k, 1) = myMass_v - else ! Radial acceleration from bubble models - intfc_dveldt(k, stage) = f_rddot(myRho, myPinf, myR, myV, myR0, & - myPb, myPbdot, dmalf, dmntait, dmBtait, & - dm_bub_adv_src, dm_divu, & - myCson) + intfc_dveldt(k, stage) = f_rddot(myRho, myPinf, myR, myV, myR0, myPb, myPbdot, dmalf, dmntait, dmBtait, & + & dm_bub_adv_src, dm_divu, myCson) intfc_draddt(k, stage) = myV gas_dmvdt(k, stage) = myMvdot gas_dpdt(k, stage) = myPbdot - end if adap_dt_stop_max = max(adap_dt_stop_max, adap_dt_stop) - end do $:END_GPU_PARALLEL_LOOP() if (adap_dt .and. adap_dt_stop_max > 0) call s_mpi_abort("Adaptive time stepping failed to converge.") ! Bubbles remain in a fixed position - $:GPU_PARALLEL_LOOP(collapse=2, private='[k,l]', copyin='[stage]') + $:GPU_PARALLEL_LOOP(collapse=2, private='[k, l]', copyin='[stage]') do k = 1, nBubs do l = 1, 3 mtn_dposdt(k, l, stage) = 0._wp @@ -651,38 +605,31 @@ contains $:END_GPU_PARALLEL_LOOP() call nvtxEndRange - end subroutine s_compute_bubble_EL_dynamics - - !> The purpose of this subroutine is to obtain the bubble source terms based on Maeda and Colonius (2018) - !! and add them to the RHS scalar field. + !> The purpose of this subroutine is to obtain the bubble source terms based on Maeda and Colonius (2018) and add them to the + !! RHS scalar field. !! @param q_cons_vf Conservative variables !! @param q_prim_vf Conservative variables !! @param rhs_vf Time derivative of the conservative variables subroutine s_compute_bubbles_EL_source(q_cons_vf, q_prim_vf, rhs_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - - integer :: i, j, k, l + integer :: i, j, k, l if (.not. adap_dt) call s_smear_voidfraction() if (lag_params%solver_approach == 2) then - ! (q / (1 - beta)) * d(beta)/dt source if (p == 0) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do k = 0, p do j = 0, n do i = 0, m do l = 1, E_idx if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then - rhs_vf(l)%sf(i, j, k) = rhs_vf(l)%sf(i, j, k) + & - q_cons_vf(l)%sf(i, j, k)*(q_beta(2)%sf(i, j, k) + & - q_beta(5)%sf(i, j, k)) - + rhs_vf(l)%sf(i, j, k) = rhs_vf(l)%sf(i, j, k) + q_cons_vf(l)%sf(i, j, k)*(q_beta(2)%sf(i, j, & + & k) + q_beta(5)%sf(i, j, k)) end if end do end do @@ -690,15 +637,14 @@ contains end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do k = 0, p do j = 0, n do i = 0, m do l = 1, E_idx if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then - rhs_vf(l)%sf(i, j, k) = rhs_vf(l)%sf(i, j, k) + & - q_cons_vf(l)%sf(i, j, k)/q_beta(1)%sf(i, j, k)* & - q_beta(2)%sf(i, j, k) + rhs_vf(l)%sf(i, j, k) = rhs_vf(l)%sf(i, j, k) + q_cons_vf(l)%sf(i, j, k)/q_beta(1)%sf(i, j, & + & k)*q_beta(2)%sf(i, j, k) end if end do end do @@ -708,27 +654,24 @@ contains end if do l = 1, num_dims - call s_gradient_dir(q_prim_vf(E_idx)%sf, q_beta(3)%sf, l) ! (q / (1 - beta)) * d(beta)/dt source - $:GPU_PARALLEL_LOOP(private='[i,j,k]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) do k = 0, p do j = 0, n do i = 0, m if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then - rhs_vf(contxe + l)%sf(i, j, k) = rhs_vf(contxe + l)%sf(i, j, k) - & - (1._wp - q_beta(1)%sf(i, j, k))/ & - q_beta(1)%sf(i, j, k)* & - q_beta(3)%sf(i, j, k) + rhs_vf(contxe + l)%sf(i, j, k) = rhs_vf(contxe + l)%sf(i, j, k) - (1._wp - q_beta(1)%sf(i, j, & + & k))/q_beta(1)%sf(i, j, k)*q_beta(3)%sf(i, j, k) end if end do end do end do $:END_GPU_PARALLEL_LOOP() - !source in energy - $:GPU_PARALLEL_LOOP(private='[i,j,k]', collapse=3) + ! source in energy + $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) do k = idwbuff(3)%beg, idwbuff(3)%end do j = idwbuff(2)%beg, idwbuff(2)%end do i = idwbuff(1)%beg, idwbuff(1)%end @@ -741,26 +684,22 @@ contains call s_gradient_dir(q_beta(3)%sf, q_beta(4)%sf, l) ! (beta / (1 - beta)) * d(Pu)/dl source - $:GPU_PARALLEL_LOOP(private='[i,j,k]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) do k = 0, p do j = 0, n do i = 0, m if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then - rhs_vf(E_idx)%sf(i, j, k) = rhs_vf(E_idx)%sf(i, j, k) - & - q_beta(4)%sf(i, j, k)*(1._wp - q_beta(1)%sf(i, j, k))/ & - q_beta(1)%sf(i, j, k) + rhs_vf(E_idx)%sf(i, j, k) = rhs_vf(E_idx)%sf(i, j, k) - q_beta(4)%sf(i, j, & + & k)*(1._wp - q_beta(1)%sf(i, j, k))/q_beta(1)%sf(i, j, k) end if end do end do end do $:END_GPU_PARALLEL_LOOP() end do - end if - end subroutine s_compute_bubbles_EL_source - - !> This procedure computes the speed of sound from a given driving pressure + !> This procedure computes the speed of sound from a given driving pressure !! @param q_prim_vf Primitive variables !! @param pinf Driving pressure !! @param cell Bubble cell @@ -769,15 +708,13 @@ contains !! @param pi_inf Liquid stiffness !! @param cson Calculated speed of sound subroutine s_compute_cson_from_pinf(q_prim_vf, pinf, cell, rhol, gamma, pi_inf, cson) - $:GPU_ROUTINE(function_name='s_compute_cson_from_pinf', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_cson_from_pinf', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), intent(in) :: pinf, rhol, gamma, pi_inf - integer, dimension(3), intent(in) :: cell - real(wp), intent(out) :: cson - - real(wp) :: E, H + real(wp), intent(in) :: pinf, rhol, gamma, pi_inf + integer, dimension(3), intent(in) :: cell + real(wp), intent(out) :: cson + real(wp) :: E, H #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: vel #:else @@ -793,17 +730,14 @@ contains E = gamma*pinf + pi_inf + 0.5_wp*rhol*dot_product(vel, vel) H = (E + pinf)/rhol cson = sqrt((H - 0.5_wp*dot_product(vel, vel))/gamma) - end subroutine s_compute_cson_from_pinf - - !> The purpose of this subroutine is to smear the effect of the bubbles in the Eulerian framework + !> The purpose of this subroutine is to smear the effect of the bubbles in the Eulerian framework subroutine s_smear_voidfraction() - integer :: i, j, k, l call nvtxStartRange("BUBBLES-LAGRANGE-KERNELS") - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = 1, q_beta_idx do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end @@ -815,27 +749,23 @@ contains end do $:END_GPU_PARALLEL_LOOP() - call s_smoothfunction(nBubs, intfc_rad, intfc_vel, & - mtn_s, mtn_pos, q_beta) + call s_smoothfunction(nBubs, intfc_rad, intfc_vel, mtn_s, mtn_pos, q_beta) - !Store 1-beta - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + ! Store 1-beta + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end q_beta(1)%sf(j, k, l) = 1._wp - q_beta(1)%sf(j, k, l) ! Limiting void fraction given max value - q_beta(1)%sf(j, k, l) = max(q_beta(1)%sf(j, k, l), & - 1._wp - lag_params%valmaxvoid) + q_beta(1)%sf(j, k, l) = max(q_beta(1)%sf(j, k, l), 1._wp - lag_params%valmaxvoid) end do end do end do $:END_GPU_PARALLEL_LOOP() call nvtxEndRange - end subroutine s_smear_voidfraction - !> The purpose of this procedure is obtain the bubble driving pressure p_inf !! @param bub_id Particle identifier !! @param q_prim_vf Primitive variables @@ -846,23 +776,21 @@ contains !! @param term2 Computed term 2 !! @param Romega Control volume radius subroutine s_get_pinf(bub_id, q_prim_vf, ptype, f_pinfl, cell, preterm1, term2, Romega) - $:GPU_ROUTINE(function_name='s_get_pinf',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_get_pinf',parallelism='[seq]', cray_inline=True) - integer, intent(in) :: bub_id, ptype + integer, intent(in) :: bub_id, ptype type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), intent(out) :: f_pinfl - integer, dimension(3), intent(out) :: cell - real(wp), intent(out), optional :: preterm1, term2, Romega - - real(wp), dimension(3) :: scoord, psi - real(wp) :: dc, vol, aux - real(wp) :: volgas, term1, Rbeq, denom - real(wp) :: charvol, charpres, charvol2, charpres2 - integer, dimension(3) :: cellaux - integer :: i, j, k - integer :: smearGrid, smearGridz - logical :: celloutside + real(wp), intent(out) :: f_pinfl + integer, dimension(3), intent(out) :: cell + real(wp), intent(out), optional :: preterm1, term2, Romega + real(wp), dimension(3) :: scoord, psi + real(wp) :: dc, vol, aux + real(wp) :: volgas, term1, Rbeq, denom + real(wp) :: charvol, charpres, charvol2, charpres2 + integer, dimension(3) :: cellaux + integer :: i, j, k + integer :: smearGrid, smearGridz + logical :: celloutside scoord = mtn_s(bub_id, 1:3, 2) f_pinfl = 0._wp @@ -927,12 +855,12 @@ contains end if !< Perform bilinear interpolation - if (p == 0) then !2D + if (p == 0) then ! 2D f_pinfl = q_prim_vf(E_idx)%sf(cell(1), cell(2), cell(3))*(1._wp - psi(1))*(1._wp - psi(2)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2), cell(3))*psi(1)*(1._wp - psi(2)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2) + 1, cell(3))*psi(1)*psi(2) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1), cell(2) + 1, cell(3))*(1._wp - psi(1))*psi(2) - else !3D + else ! 3D f_pinfl = q_prim_vf(E_idx)%sf(cell(1), cell(2), cell(3))*(1._wp - psi(1))*(1._wp - psi(2))*(1._wp - psi(3)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2), cell(3))*psi(1)*(1._wp - psi(2))*(1._wp - psi(3)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2) + 1, cell(3))*psi(1)*psi(2)*(1._wp - psi(3)) @@ -943,9 +871,8 @@ contains f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1), cell(2) + 1, cell(3) + 1)*(1._wp - psi(1))*psi(2)*psi(3) end if - !R_Omega + ! R_Omega dc = (3._wp*vol/(4._wp*pi))**(1._wp/3._wp) - else if (lag_params%cluster_type >= 2) then ! Bubble dynamic closure from Maeda and Colonius (2018) @@ -988,7 +915,8 @@ contains celloutside = .true. end if - if ((cellaux(3) > p + buff_size) .or. (cellaux(2) > n + buff_size) .or. (cellaux(1) > m + buff_size)) then + if ((cellaux(3) > p + buff_size) .or. (cellaux(2) > n + buff_size) .or. (cellaux(1) > m + buff_size)) & + & then celloutside = .true. end if end if @@ -1013,10 +941,9 @@ contains charvol = charvol + vol charpres = charpres + q_prim_vf(E_idx)%sf(cellaux(1), cellaux(2), cellaux(3))*vol charvol2 = charvol2 + vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) - charpres2 = charpres2 + q_prim_vf(E_idx)%sf(cellaux(1), cellaux(2), cellaux(3)) & - *vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) + charpres2 = charpres2 + q_prim_vf(E_idx)%sf(cellaux(1), cellaux(2), & + & cellaux(3))*vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) end if - end do end do end do @@ -1024,48 +951,41 @@ contains f_pinfl = charpres2/charvol2 vol = charvol dc = (3._wp*abs(vol)/(4._wp*pi))**(1._wp/3._wp) - end if if (lag_params%pressure_corrector) then - - !Valid if only one bubble exists per cell + ! Valid if only one bubble exists per cell volgas = intfc_rad(bub_id, 2)**3._wp denom = intfc_rad(bub_id, 2)**2._wp term1 = bub_dphidt(bub_id)*intfc_rad(bub_id, 2)**2._wp term2 = intfc_vel(bub_id, 2)*intfc_rad(bub_id, 2)**2._wp - Rbeq = volgas**(1._wp/3._wp) !surrogate bubble radius + Rbeq = volgas**(1._wp/3._wp) ! surrogate bubble radius aux = dc**3._wp - Rbeq**3._wp term2 = term2/denom term2 = 3._wp/2._wp*term2**2._wp*Rbeq**3._wp*(1._wp - Rbeq/dc)/aux preterm1 = 3._wp/2._wp*Rbeq*(dc**2._wp - Rbeq**2._wp)/(aux*denom) - !Control volume radius + ! Control volume radius if (ptype == 2) Romega = dc ! Getting p_inf if (ptype == 1) then f_pinfl = f_pinfl + preterm1*term1 + term2 end if - end if - end subroutine s_get_pinf - - !> This subroutine updates the Lagrange variables using the tvd RK time steppers. - !! The time derivative of the bubble variables must be stored at every stage to avoid precision errors. + !> This subroutine updates the Lagrange variables using the tvd RK time steppers. The time derivative of the bubble variables + !! must be stored at every stage to avoid precision errors. !! @param stage Current tvd RK stage impure subroutine s_update_lagrange_tdv_rk(stage) - integer, intent(in) :: stage - - integer :: k + integer :: k if (time_stepper == 1) then ! 1st order TVD RK $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs - !u{1} = u{n} + dt * RHS{n} + ! u{1} = u{n} + dt * RHS{n} intfc_rad(k, 1) = intfc_rad(k, 1) + dt*intfc_draddt(k, 1) intfc_vel(k, 1) = intfc_vel(k, 1) + dt*intfc_dveldt(k, 1) mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + dt*mtn_dposdt(k, 1:3, 1) @@ -1080,15 +1000,14 @@ contains if (lag_params%write_bubbles_stats) call s_calculate_lag_bubble_stats() if (lag_params%write_bubbles) then - $:GPU_UPDATE(host='[gas_p,gas_mv,intfc_rad,intfc_vel]') + $:GPU_UPDATE(host='[gas_p, gas_mv, intfc_rad, intfc_vel]') call s_write_lag_particles(mytime) end if - - elseif (time_stepper == 2) then ! 2nd order TVD RK + else if (time_stepper == 2) then ! 2nd order TVD RK if (stage == 1) then $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs - !u{1} = u{n} + dt * RHS{n} + ! u{1} = u{n} + dt * RHS{n} intfc_rad(k, 2) = intfc_rad(k, 1) + dt*intfc_draddt(k, 1) intfc_vel(k, 2) = intfc_vel(k, 1) + dt*intfc_dveldt(k, 1) mtn_pos(k, 1:3, 2) = mtn_pos(k, 1:3, 1) + dt*mtn_dposdt(k, 1:3, 1) @@ -1097,11 +1016,10 @@ contains gas_mv(k, 2) = gas_mv(k, 1) + dt*gas_dmvdt(k, 1) end do $:END_GPU_PARALLEL_LOOP() - - elseif (stage == 2) then + else if (stage == 2) then $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs - !u{1} = u{n} + (1/2) * dt * (RHS{n} + RHS{1}) + ! u{1} = u{n} + (1/2) * dt * (RHS{n} + RHS{1}) intfc_rad(k, 1) = intfc_rad(k, 1) + dt*(intfc_draddt(k, 1) + intfc_draddt(k, 2))/2._wp intfc_vel(k, 1) = intfc_vel(k, 1) + dt*(intfc_dveldt(k, 1) + intfc_dveldt(k, 2))/2._wp mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + dt*(mtn_dposdt(k, 1:3, 1) + mtn_dposdt(k, 1:3, 2))/2._wp @@ -1116,17 +1034,15 @@ contains if (lag_params%write_bubbles_stats) call s_calculate_lag_bubble_stats() if (lag_params%write_bubbles) then - $:GPU_UPDATE(host='[gas_p,gas_mv,intfc_rad,intfc_vel]') + $:GPU_UPDATE(host='[gas_p, gas_mv, intfc_rad, intfc_vel]') call s_write_lag_particles(mytime) end if - end if - - elseif (time_stepper == 3) then ! 3rd order TVD RK + else if (time_stepper == 3) then ! 3rd order TVD RK if (stage == 1) then $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs - !u{1} = u{n} + dt * RHS{n} + ! u{1} = u{n} + dt * RHS{n} intfc_rad(k, 2) = intfc_rad(k, 1) + dt*intfc_draddt(k, 1) intfc_vel(k, 2) = intfc_vel(k, 1) + dt*intfc_dveldt(k, 1) mtn_pos(k, 1:3, 2) = mtn_pos(k, 1:3, 1) + dt*mtn_dposdt(k, 1:3, 1) @@ -1135,11 +1051,10 @@ contains gas_mv(k, 2) = gas_mv(k, 1) + dt*gas_dmvdt(k, 1) end do $:END_GPU_PARALLEL_LOOP() - - elseif (stage == 2) then + else if (stage == 2) then $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs - !u{2} = u{n} + (1/4) * dt * [RHS{n} + RHS{1}] + ! u{2} = u{n} + (1/4) * dt * [RHS{n} + RHS{1}] intfc_rad(k, 2) = intfc_rad(k, 1) + dt*(intfc_draddt(k, 1) + intfc_draddt(k, 2))/4._wp intfc_vel(k, 2) = intfc_vel(k, 1) + dt*(intfc_dveldt(k, 1) + intfc_dveldt(k, 2))/4._wp mtn_pos(k, 1:3, 2) = mtn_pos(k, 1:3, 1) + dt*(mtn_dposdt(k, 1:3, 1) + mtn_dposdt(k, 1:3, 2))/4._wp @@ -1148,14 +1063,18 @@ contains gas_mv(k, 2) = gas_mv(k, 1) + dt*(gas_dmvdt(k, 1) + gas_dmvdt(k, 2))/4._wp end do $:END_GPU_PARALLEL_LOOP() - elseif (stage == 3) then + else if (stage == 3) then $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs - !u{n+1} = u{n} + (2/3) * dt * [(1/4)* RHS{n} + (1/4)* RHS{1} + RHS{2}] - intfc_rad(k, 1) = intfc_rad(k, 1) + (2._wp/3._wp)*dt*(intfc_draddt(k, 1)/4._wp + intfc_draddt(k, 2)/4._wp + intfc_draddt(k, 3)) - intfc_vel(k, 1) = intfc_vel(k, 1) + (2._wp/3._wp)*dt*(intfc_dveldt(k, 1)/4._wp + intfc_dveldt(k, 2)/4._wp + intfc_dveldt(k, 3)) - mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dposdt(k, 1:3, 1)/4._wp + mtn_dposdt(k, 1:3, 2)/4._wp + mtn_dposdt(k, 1:3, 3)) - mtn_vel(k, 1:3, 1) = mtn_vel(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dveldt(k, 1:3, 1)/4._wp + mtn_dveldt(k, 1:3, 2)/4._wp + mtn_dveldt(k, 1:3, 3)) + ! u{n+1} = u{n} + (2/3) * dt * [(1/4)* RHS{n} + (1/4)* RHS{1} + RHS{2}] + intfc_rad(k, 1) = intfc_rad(k, 1) + (2._wp/3._wp)*dt*(intfc_draddt(k, 1)/4._wp + intfc_draddt(k, & + & 2)/4._wp + intfc_draddt(k, 3)) + intfc_vel(k, 1) = intfc_vel(k, 1) + (2._wp/3._wp)*dt*(intfc_dveldt(k, 1)/4._wp + intfc_dveldt(k, & + & 2)/4._wp + intfc_dveldt(k, 3)) + mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dposdt(k, 1:3, 1)/4._wp + mtn_dposdt(k, 1:3, & + & 2)/4._wp + mtn_dposdt(k, 1:3, 3)) + mtn_vel(k, 1:3, 1) = mtn_vel(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dveldt(k, 1:3, 1)/4._wp + mtn_dveldt(k, 1:3, & + & 2)/4._wp + mtn_dveldt(k, 1:3, 3)) gas_p(k, 1) = gas_p(k, 1) + (2._wp/3._wp)*dt*(gas_dpdt(k, 1)/4._wp + gas_dpdt(k, 2)/4._wp + gas_dpdt(k, 3)) gas_mv(k, 1) = gas_mv(k, 1) + (2._wp/3._wp)*dt*(gas_dmvdt(k, 1)/4._wp + gas_dmvdt(k, 2)/4._wp + gas_dmvdt(k, 3)) end do @@ -1166,27 +1085,21 @@ contains if (lag_params%write_bubbles_stats) call s_calculate_lag_bubble_stats() if (lag_params%write_bubbles) then - $:GPU_UPDATE(host='[gas_p,gas_mv,gas_mg,intfc_rad,intfc_vel]') + $:GPU_UPDATE(host='[gas_p, gas_mv, gas_mg, intfc_rad, intfc_vel]') call s_write_lag_particles(mytime) end if - end if - end if - end subroutine s_update_lagrange_tdv_rk - !> This subroutine returns the computational coordinate of the cell for the given position. !! @param pos Input coordinates !! @param cell Computational coordinate of the cell !! @param scoord Calculated particle coordinates subroutine s_locate_cell(pos, cell, scoord) - - real(wp), dimension(3), intent(in) :: pos - real(wp), dimension(3), intent(out) :: scoord + real(wp), dimension(3), intent(in) :: pos + real(wp), dimension(3), intent(out) :: scoord integer, dimension(3), intent(inout) :: cell - - integer :: i + integer :: i do while (pos(1) < x_cb(cell(1) - 1)) cell(1) = cell(1) - 1 @@ -1219,7 +1132,7 @@ contains ! + (s-(int(s))*(cell-width). ! In other words, the coordinate of the center of the cell is x_cc(cell). - !coordinates in computational space + ! coordinates in computational space scoord(1) = cell(1) + (pos(1) - x_cb(cell(1) - 1))/dx(cell(1)) scoord(2) = cell(2) + (pos(2) - y_cb(cell(2) - 1))/dy(cell(2)) scoord(3) = 0._wp @@ -1228,12 +1141,9 @@ contains do i = 1, num_dims if (scoord(i) < 0._wp) cell(i) = cell(i) - 1 end do - end subroutine s_locate_cell - !> This subroutine transfer data into the temporal variables. impure subroutine s_transfer_data_to_tmp() - integer :: k $:GPU_PARALLEL_LOOP(private='[k]') @@ -1248,35 +1158,34 @@ contains mtn_s(k, 1:3, 2) = mtn_s(k, 1:3, 1) end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_transfer_data_to_tmp - - !> The purpose of this procedure is to determine if the global coordinates of the bubbles - !! are present in the current MPI processor (including ghost cells). + !> The purpose of this procedure is to determine if the global coordinates of the bubbles are present in the current MPI + !! processor (including ghost cells). !! @param pos_part Spatial coordinates of the bubble function particle_in_domain(pos_part) - - logical :: particle_in_domain + logical :: particle_in_domain real(wp), dimension(3), intent(in) :: pos_part ! 2D if (p == 0 .and. cyl_coord .neqv. .true.) then ! Defining a virtual z-axis that has the same dimensions as y-axis ! defined in the input file - particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) .and. & - (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) .and. & - (pos_part(3) < lag_params%charwidth/2._wp) .and. (pos_part(3) >= -lag_params%charwidth/2._wp)) + particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & + & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) & + & .and. (pos_part(3) < lag_params%charwidth/2._wp) .and. (pos_part(3) >= & + & -lag_params%charwidth/2._wp)) else ! cyl_coord - particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) .and. & - (abs(pos_part(2)) < y_cb(n + buff_size)) .and. (abs(pos_part(2)) >= max(y_cb(-buff_size - 1), 0._wp))) + particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & + & .and. (abs(pos_part(2)) < y_cb(n + buff_size)) .and. (abs(pos_part(2)) >= max(y_cb(-buff_size & + & - 1), 0._wp))) end if ! 3D if (p > 0) then - particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) .and. & - (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) .and. & - (pos_part(3) < z_cb(p + buff_size)) .and. (pos_part(3) >= z_cb(-buff_size - 1))) + particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & + & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) & + & .and. (pos_part(3) < z_cb(p + buff_size)) .and. (pos_part(3) >= z_cb(-buff_size - 1))) end if ! For symmetric and wall boundary condition @@ -1300,101 +1209,84 @@ contains particle_in_domain = (particle_in_domain .and. (pos_part(3) < z_cb(p))) end if end if - end function particle_in_domain - - !> The purpose of this procedure is to determine if the lagrangian bubble is located in the - !! physical domain. The ghost cells are not part of the physical domain. + !> The purpose of this procedure is to determine if the lagrangian bubble is located in the physical domain. The ghost cells are + !! not part of the physical domain. !! @param pos_part Spatial coordinates of the bubble function particle_in_domain_physical(pos_part) - - logical :: particle_in_domain_physical + logical :: particle_in_domain_physical real(wp), dimension(3), intent(in) :: pos_part - particle_in_domain_physical = ((pos_part(1) < x_cb(m)) .and. (pos_part(1) >= x_cb(-1)) .and. & - (pos_part(2) < y_cb(n)) .and. (pos_part(2) >= y_cb(-1))) + particle_in_domain_physical = ((pos_part(1) < x_cb(m)) .and. (pos_part(1) >= x_cb(-1)) .and. (pos_part(2) < y_cb(n)) & + & .and. (pos_part(2) >= y_cb(-1))) if (p > 0) then - particle_in_domain_physical = (particle_in_domain_physical .and. (pos_part(3) < z_cb(p)) .and. (pos_part(3) >= z_cb(-1))) + particle_in_domain_physical = (particle_in_domain_physical .and. (pos_part(3) < z_cb(p)) .and. (pos_part(3) & + & >= z_cb(-1))) end if - end function particle_in_domain_physical - - !> The purpose of this procedure is to calculate the gradient of a scalar field along the x, y and z directions - !! following a second-order central difference considering uneven widths + !> The purpose of this procedure is to calculate the gradient of a scalar field along the x, y and z directions following a + !! second-order central difference considering uneven widths !! @param q Input scalar field !! @param dq Output gradient of q !! @param dir Gradient spatial direction subroutine s_gradient_dir(q, dq, dir) - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:), intent(inout) :: q, dq - integer, intent(in) :: dir - - integer :: i, j, k + integer, intent(in) :: dir + integer :: i, j, k if (dir == 1) then ! Gradient in x dir. - $:GPU_PARALLEL_LOOP(private='[i,j,k]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) do k = 0, p do j = 0, n do i = 0, m - dq(i, j, k) = q(i, j, k)*(dx(i + 1) - dx(i - 1)) & - + q(i + 1, j, k)*(dx(i) + dx(i - 1)) & - - q(i - 1, j, k)*(dx(i) + dx(i + 1)) - dq(i, j, k) = dq(i, j, k)/ & - ((dx(i) + dx(i - 1))*(dx(i) + dx(i + 1))) + dq(i, j, k) = q(i, j, k)*(dx(i + 1) - dx(i - 1)) + q(i + 1, j, k)*(dx(i) + dx(i - 1)) - q(i - 1, j, & + & k)*(dx(i) + dx(i + 1)) + dq(i, j, k) = dq(i, j, k)/((dx(i) + dx(i - 1))*(dx(i) + dx(i + 1))) end do end do end do $:END_GPU_PARALLEL_LOOP() - elseif (dir == 2) then + else if (dir == 2) then ! Gradient in y dir. - $:GPU_PARALLEL_LOOP(private='[i,j,k]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) do k = 0, p do j = 0, n do i = 0, m - dq(i, j, k) = q(i, j, k)*(dy(j + 1) - dy(j - 1)) & - + q(i, j + 1, k)*(dy(j) + dy(j - 1)) & - - q(i, j - 1, k)*(dy(j) + dy(j + 1)) - dq(i, j, k) = dq(i, j, k)/ & - ((dy(j) + dy(j - 1))*(dy(j) + dy(j + 1))) + dq(i, j, k) = q(i, j, k)*(dy(j + 1) - dy(j - 1)) + q(i, j + 1, k)*(dy(j) + dy(j - 1)) - q(i, j - 1, & + & k)*(dy(j) + dy(j + 1)) + dq(i, j, k) = dq(i, j, k)/((dy(j) + dy(j - 1))*(dy(j) + dy(j + 1))) end do end do end do $:END_GPU_PARALLEL_LOOP() - elseif (dir == 3) then + else if (dir == 3) then ! Gradient in z dir. - $:GPU_PARALLEL_LOOP(private='[i,j,k]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) do k = 0, p do j = 0, n do i = 0, m - dq(i, j, k) = q(i, j, k)*(dz(k + 1) - dz(k - 1)) & - + q(i, j, k + 1)*(dz(k) + dz(k - 1)) & - - q(i, j, k - 1)*(dz(k) + dz(k + 1)) - dq(i, j, k) = dq(i, j, k)/ & - ((dz(k) + dz(k - 1))*(dz(k) + dz(k + 1))) + dq(i, j, k) = q(i, j, k)*(dz(k + 1) - dz(k - 1)) + q(i, j, k + 1)*(dz(k) + dz(k - 1)) - q(i, j, & + & k - 1)*(dz(k) + dz(k + 1)) + dq(i, j, k) = dq(i, j, k)/((dz(k) + dz(k - 1))*(dz(k) + dz(k + 1))) end do end do end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_gradient_dir - !> Subroutine that writes on each time step the changes of the lagrangian bubbles. - !! @param qtime Current time + !! @param qtime Current time impure subroutine s_write_lag_particles(qtime) - - real(wp), intent(in) :: qtime - integer :: k - + real(wp), intent(in) :: qtime + integer :: k character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist - - character(LEN=25) :: FMT + logical :: file_exist + character(LEN=25) :: FMT write (file_loc, '(A,I0,A)') 'lag_bubble_evol_', proc_rank, '.dat' - file_loc = trim(case_dir)//'/D/'//trim(file_loc) + file_loc = trim(case_dir) // '/D/' // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (precision == 1) then @@ -1404,12 +1296,11 @@ contains end if if (.not. file_exist) then - open (11, FILE=trim(file_loc), FORM='formatted', position='rewind') - write (11, FMT) 'currentTime', 'particleID', 'x', 'y', 'z', & - 'coreVaporMass', 'coreVaporConcentration', 'radius', 'interfaceVelocity', & - 'corePressure' + open (11, FILE=trim(file_loc), form='formatted', position='rewind') + write (11, FMT) 'currentTime', 'particleID', 'x', 'y', 'z', 'coreVaporMass', 'coreVaporConcentration', 'radius', & + & 'interfaceVelocity', 'corePressure' else - open (11, FILE=trim(file_loc), FORM='formatted', position='append') + open (11, FILE=trim(file_loc), form='formatted', position='append') end if if (precision == 1) then @@ -1420,59 +1311,45 @@ contains ! Cycle through list do k = 1, nBubs - write (11, FMT) & - qtime, & - lag_id(k, 1), & - mtn_pos(k, 1, 1), & - mtn_pos(k, 2, 1), & - mtn_pos(k, 3, 1), & - gas_mv(k, 1), & - gas_mv(k, 1)/(gas_mv(k, 1) + gas_mg(k)), & - intfc_rad(k, 1), & - intfc_vel(k, 1), & - gas_p(k, 1) + write (11, FMT) qtime, lag_id(k, 1), mtn_pos(k, 1, 1), mtn_pos(k, 2, 1), mtn_pos(k, 3, 1), gas_mv(k, 1), gas_mv(k, & + & 1)/(gas_mv(k, 1) + gas_mg(k)), intfc_rad(k, 1), intfc_vel(k, 1), gas_p(k, 1) end do close (11) - end subroutine s_write_lag_particles - - !> Subroutine that writes some useful statistics related to the volume fraction - !! of the particles (void fraction) in the computatioational domain - !! on each time step. - !! @param qtime Current time + !> Subroutine that writes some useful statistics related to the volume fraction of the particles (void fraction) in the + !! computatioational domain on each time step. + !! @param qtime Current time impure subroutine s_write_void_evol(qtime) - - real(wp), intent(in) :: qtime - real(wp) :: volcell, voltot - real(wp) :: lag_void_max, lag_void_avg, lag_vol - real(wp) :: void_max_glb, void_avg_glb, vol_glb - - integer :: i, j, k - + real(wp), intent(in) :: qtime + real(wp) :: volcell, voltot + real(wp) :: lag_void_max, lag_void_avg, lag_vol + real(wp) :: void_max_glb, void_avg_glb, vol_glb + integer :: i, j, k character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist + logical :: file_exist if (proc_rank == 0) then write (file_loc, '(A)') 'voidfraction.dat' - file_loc = trim(case_dir)//'/D/'//trim(file_loc) + file_loc = trim(case_dir) // '/D/' // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (.not. file_exist) then - open (12, FILE=trim(file_loc), FORM='formatted', position='rewind') - !write (12, *) 'currentTime, averageVoidFraction, ', & + open (12, FILE=trim(file_loc), form='formatted', position='rewind') + ! write (12, *) 'currentTime, averageVoidFraction, ', & ! 'maximumVoidFraction, totalParticlesVolume' - !write (12, *) 'The averageVoidFraction value does ', & + ! write (12, *) 'The averageVoidFraction value does ', & ! 'not reflect the real void fraction in the cloud since the ', & ! 'cells which do not have bubbles are not accounted' else - open (12, FILE=trim(file_loc), FORM='formatted', position='append') + open (12, FILE=trim(file_loc), form='formatted', position='append') end if end if lag_void_max = 0._wp lag_void_avg = 0._wp lag_vol = 0._wp - $:GPU_PARALLEL_LOOP(private='[volcell]', collapse=3, reduction='[[lag_vol, lag_void_avg], [lag_void_max]]', reductionOp='[+, MAX]', copy='[lag_vol, lag_void_avg, lag_void_max]') + $:GPU_PARALLEL_LOOP(private='[volcell]', collapse=3, reduction='[[lag_vol, lag_void_avg], [lag_void_max]]', & + & reductionOp='[+, MAX]', copy='[lag_vol, lag_void_avg, lag_void_max]') do k = 0, p do j = 0, n do i = 0, m @@ -1503,36 +1380,28 @@ contains if (lag_vol > 0._wp) lag_void_avg = lag_void_avg/lag_vol if (proc_rank == 0) then - write (12, '(6X,4e24.8)') & - qtime, & - lag_void_avg, & - lag_void_max, & - voltot + write (12, '(6X,4e24.8)') qtime, lag_void_avg, lag_void_max, voltot close (12) end if - end subroutine s_write_void_evol - - !> Subroutine that writes the restarting files for the particles in the lagrangian solver. - !! @param t_step Current time step + !> Subroutine that writes the restarting files for the particles in the lagrangian solver. + !! @param t_step Current time step impure subroutine s_write_restart_lag_bubbles(t_step) - ! Generic string used to store the address of a particular file - integer, intent(in) :: t_step - + integer, intent(in) :: t_step character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist - integer :: bub_id, tot_part - integer :: i, k + logical :: file_exist + integer :: bub_id, tot_part + integer :: i, k #ifdef MFC_MPI ! For Parallel I/O - integer :: ifile, ierr - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer :: view - integer, dimension(2) :: gsizes, lsizes, start_idx_part - integer, allocatable :: proc_bubble_counts(:) + integer :: ifile, ierr + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer :: view + integer, dimension(2) :: gsizes, lsizes, start_idx_part + integer, allocatable :: proc_bubble_counts(:) real(wp), dimension(1:1, 1:lag_io_vars) :: dummy dummy = 0._wp @@ -1553,11 +1422,9 @@ contains lsizes(2) = lag_io_vars ! Total number of particles - call MPI_ALLREDUCE(bub_id, tot_part, 1, MPI_integer, & - MPI_SUM, MPI_COMM_WORLD, ierr) + call MPI_ALLREDUCE(bub_id, tot_part, 1, MPI_integer, MPI_SUM, MPI_COMM_WORLD, ierr) - call MPI_ALLGATHER(bub_id, 1, MPI_INTEGER, proc_bubble_counts, 1, MPI_INTEGER, & - MPI_COMM_WORLD, ierr) + call MPI_ALLGATHER(bub_id, 1, MPI_INTEGER, proc_bubble_counts, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) ! Calculate starting index for this processor's particles call MPI_EXSCAN(lsizes(1), start_idx_part(1), 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -1568,7 +1435,7 @@ contains gsizes(2) = lag_io_vars write (file_loc, '(A,I0,A)') 'lag_bubbles_', t_step, '.dat' - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) ! Clean up existing file if (proc_rank == 0) then @@ -1581,9 +1448,7 @@ contains call MPI_BARRIER(MPI_COMM_WORLD, ierr) if (proc_rank == 0) then - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, & - ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) ! Write header using MPI I/O for consistency call MPI_FILE_WRITE(ifile, tot_part, 1, MPI_INTEGER, status, ierr) @@ -1622,37 +1487,30 @@ contains end if end do - call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, & - MPI_ORDER_FORTRAN, mpi_p, view, ierr) + call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, MPI_ORDER_FORTRAN, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, & - ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) ! Skip header (written by rank 0) - disp = int(sizeof(tot_part) + 2*sizeof(mytime) + sizeof(num_procs) + & - num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + disp = int(sizeof(tot_part) + 2*sizeof(mytime) + sizeof(num_procs) + num_procs*sizeof(proc_bubble_counts(1)), & + & MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA_lag_bubbles, & - lag_io_vars*bub_id, mpi_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA_lag_bubbles, lag_io_vars*bub_id, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) deallocate (MPI_IO_DATA_lag_bubbles) - else call MPI_TYPE_CONTIGUOUS(0, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, & - ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) ! Skip header (written by rank 0) - disp = int(sizeof(tot_part) + 2*sizeof(mytime) + sizeof(num_procs) + & - num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + disp = int(sizeof(tot_part) + 2*sizeof(mytime) + sizeof(num_procs) + num_procs*sizeof(proc_bubble_counts(1)), & + & MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -1661,18 +1519,13 @@ contains end if deallocate (proc_bubble_counts) - #endif - end subroutine s_write_restart_lag_bubbles - - !> This procedure calculates the maximum and minimum radius of each bubble. + !> This procedure calculates the maximum and minimum radius of each bubble. subroutine s_calculate_lag_bubble_stats() - integer :: k - $:GPU_PARALLEL_LOOP(private='[k]', reduction='[[Rmax_glb], [Rmin_glb]]', & - & reductionOp='[MAX, MIN]', copy='[Rmax_glb,Rmin_glb]') + $:GPU_PARALLEL_LOOP(private='[k]', reduction='[[Rmax_glb], [Rmin_glb]]', reductionOp='[MAX, MIN]', copy='[Rmax_glb, Rmin_glb]') do k = 1, nBubs Rmax_glb = max(Rmax_glb, intfc_rad(k, 1)/bub_R0(k)) Rmin_glb = min(Rmin_glb, intfc_rad(k, 1)/bub_R0(k)) @@ -1680,21 +1533,17 @@ contains Rmin_stats(k) = min(Rmin_stats(k), intfc_rad(k, 1)/bub_R0(k)) end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_calculate_lag_bubble_stats - - !> Subroutine that writes the maximum and minimum radius of each bubble. + !> Subroutine that writes the maximum and minimum radius of each bubble. impure subroutine s_write_lag_bubble_stats() - - integer :: k + integer :: k character(LEN=path_len + 2*name_len) :: file_loc - - character(len=20) :: FMT + character(len=20) :: FMT write (file_loc, '(A,I0,A)') 'stats_lag_bubbles_', proc_rank, '.dat' - file_loc = trim(case_dir)//'/D/'//trim(file_loc) + file_loc = trim(case_dir) // '/D/' // trim(file_loc) - $:GPU_UPDATE(host='[Rmax_glb,Rmin_glb]') + $:GPU_UPDATE(host='[Rmax_glb, Rmin_glb]') if (precision == 1) then FMT = "(A10,A14,5A16)" @@ -1702,7 +1551,7 @@ contains FMT = "(A10,A14,5A24)" end if - open (13, FILE=trim(file_loc), FORM='formatted', position='rewind') + open (13, FILE=trim(file_loc), form='formatted', position='rewind') write (13, FMT) 'proc_rank', 'particleID', 'x', 'y', 'z', 'Rmax_glb', 'Rmin_glb' if (precision == 1) then @@ -1712,27 +1561,17 @@ contains end if do k = 1, nBubs - write (13, FMT) & - proc_rank, & - lag_id(k, 1), & - mtn_pos(k, 1, 1), & - mtn_pos(k, 2, 1), & - mtn_pos(k, 3, 1), & - Rmax_stats(k), & - Rmin_stats(k) + write (13, FMT) proc_rank, lag_id(k, 1), mtn_pos(k, 1, 1), mtn_pos(k, 2, 1), mtn_pos(k, 3, 1), Rmax_stats(k), & + & Rmin_stats(k) end do close (13) - end subroutine s_write_lag_bubble_stats - !> The purpose of this subroutine is to remove one specific particle if dt is too small. !! @param bub_id Particle id impure subroutine s_remove_lag_bubble(bub_id) - integer, intent(in) :: bub_id - - integer :: i + integer :: i $:GPU_LOOP(parallelism='[seq]') do i = bub_id, nBubs - 1 @@ -1760,12 +1599,9 @@ contains nBubs = nBubs - 1 $:GPU_UPDATE(device='[nBubs]') - end subroutine s_remove_lag_bubble - !> The purpose of this subroutine is to deallocate variables impure subroutine s_finalize_lagrangian_solver() - integer :: i do i = 1, q_beta_idx @@ -1773,7 +1609,7 @@ contains end do @:DEALLOCATE(q_beta) - !Deallocating space + ! Deallocating space @:DEALLOCATE(lag_id) @:DEALLOCATE(bub_R0) @:DEALLOCATE(Rmax_stats) @@ -1796,7 +1632,5 @@ contains @:DEALLOCATE(gas_dmvdt) @:DEALLOCATE(mtn_dposdt) @:DEALLOCATE(mtn_dveldt) - end subroutine s_finalize_lagrangian_solver - end module m_bubbles_EL diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index 784abc5adb..0bb8885235 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -6,15 +6,13 @@ !> @brief Kernel functions (Gaussian, delta) that smear Lagrangian bubble effects onto the Eulerian grid module m_bubbles_EL_kernels - use m_mpi_proxy !< Message passing interface (MPI) module proxy implicit none - contains - !> The purpose of this subroutine is to smear the strength of the lagrangian - !! bubbles into the Eulerian framework using different approaches. + !> The purpose of this subroutine is to smear the strength of the lagrangian bubbles into the Eulerian framework using different + !! approaches. !! @param nBubs Number of lagrangian bubbles in the current domain !! @param lbk_rad Radius of the bubbles !! @param lbk_vel Interface velocity of the bubbles @@ -22,41 +20,34 @@ contains !! @param lbk_pos Spatial coordinates of the bubbles !! @param updatedvar Eulerian variable to be updated subroutine s_smoothfunction(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) - - integer, intent(in) :: nBubs + integer, intent(in) :: nBubs real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s, lbk_pos - real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel - type(scalar_field), dimension(:), intent(inout) :: updatedvar + real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel + type(scalar_field), dimension(:), intent(inout) :: updatedvar smoothfunc:select case(lag_params%smooth_type) case (1) - call s_gaussian(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) + call s_gaussian(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) case (2) - call s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) + call s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) end select smoothfunc - end subroutine s_smoothfunction - - !> The purpose of this procedure contains the algorithm to use the delta kernel function to map the effect of the bubbles. - !! The effect of the bubbles only affects the cell where the bubble is located. + !> The purpose of this procedure contains the algorithm to use the delta kernel function to map the effect of the bubbles. The + !! effect of the bubbles only affects the cell where the bubble is located. subroutine s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) - - integer, intent(in) :: nBubs + integer, intent(in) :: nBubs real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s - real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel - type(scalar_field), dimension(:), intent(inout) :: updatedvar - - integer, dimension(3) :: cell - real(wp) :: strength_vel, strength_vol - - real(wp) :: addFun1, addFun2, addFun3 - real(wp) :: volpart, Vol - real(wp), dimension(3) :: s_coord - integer :: l - - $:GPU_PARALLEL_LOOP(private='[l,s_coord,cell]') + real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel + type(scalar_field), dimension(:), intent(inout) :: updatedvar + integer, dimension(3) :: cell + real(wp) :: strength_vel, strength_vol + real(wp) :: addFun1, addFun2, addFun3 + real(wp) :: volpart, Vol + real(wp), dimension(3) :: s_coord + integer :: l + + $:GPU_PARALLEL_LOOP(private='[l, s_coord, cell]') do l = 1, nBubs - volpart = 4._wp/3._wp*pi*lbk_rad(l, 2)**3._wp s_coord(1:3) = lbk_s(l, 1:3, 2) call s_get_cell(s_coord, cell) @@ -71,18 +62,18 @@ contains Vol = dx(cell(1))*dy(cell(2))*dz(cell(3)) end if - !Update void fraction field + ! Update void fraction field addFun1 = strength_vol/Vol $:GPU_ATOMIC(atomic='update') updatedvar(1)%sf(cell(1), cell(2), cell(3)) = updatedvar(1)%sf(cell(1), cell(2), cell(3)) + real(addFun1, kind=stp) - !Update time derivative of void fraction + ! Update time derivative of void fraction addFun2 = strength_vel/Vol $:GPU_ATOMIC(atomic='update') updatedvar(2)%sf(cell(1), cell(2), cell(3)) = updatedvar(2)%sf(cell(1), cell(2), cell(3)) + real(addFun2, kind=stp) - !Product of two smeared functions - !Update void fraction * time derivative of void fraction + ! Product of two smeared functions + ! Update void fraction * time derivative of void fraction if (lag_params%cluster_type >= 4) then addFun3 = (strength_vol*strength_vel)/Vol $:GPU_ATOMIC(atomic='update') @@ -90,37 +81,32 @@ contains end if end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_deltafunc - !> The purpose of this procedure contains the algorithm to use the gaussian kernel function to map the effect of the bubbles. - !! The effect of the bubbles affects the 3X3x3 cells that surround the bubble. + !! The effect of the bubbles affects the 3X3x3 cells that surround the bubble. subroutine s_gaussian(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) - - integer, intent(in) :: nBubs + integer, intent(in) :: nBubs real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s, lbk_pos - real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel - type(scalar_field), dimension(:), intent(inout) :: updatedvar - - real(wp), dimension(3) :: center - integer, dimension(3) :: cell - real(wp) :: stddsv - real(wp) :: strength_vel, strength_vol - - real(wp), dimension(3) :: nodecoord - real(wp) :: addFun1, addFun2, addFun3 - real(wp) :: func, func2, volpart - integer, dimension(3) :: cellaux - real(wp), dimension(3) :: s_coord - integer :: l, i, j, k - logical :: celloutside - integer :: smearGrid, smearGridz + real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel + type(scalar_field), dimension(:), intent(inout) :: updatedvar + real(wp), dimension(3) :: center + integer, dimension(3) :: cell + real(wp) :: stddsv + real(wp) :: strength_vel, strength_vol + real(wp), dimension(3) :: nodecoord + real(wp) :: addFun1, addFun2, addFun3 + real(wp) :: func, func2, volpart + integer, dimension(3) :: cellaux + real(wp), dimension(3) :: s_coord + integer :: l, i, j, k + logical :: celloutside + integer :: smearGrid, smearGridz smearGrid = mapCells - (-mapCells) + 1 ! Include the cell that contains the bubble (3+1+3) smearGridz = smearGrid if (p == 0) smearGridz = 1 - $:GPU_PARALLEL_LOOP(private='[nodecoord,l,s_coord,cell,center]', copyin='[smearGrid,smearGridz]') + $:GPU_PARALLEL_LOOP(private='[nodecoord, l, s_coord, cell, center]', copyin='[smearGrid, smearGridz]') do l = 1, nBubs nodecoord(1:3) = 0 center(1:3) = 0._wp @@ -134,7 +120,7 @@ contains strength_vol = volpart strength_vel = 4._wp*pi*lbk_rad(l, 2)**2._wp*lbk_vel(l, 2) - $:GPU_LOOP(collapse=3,private='[cellaux,nodecoord]') + $:GPU_LOOP(collapse=3,private='[cellaux, nodecoord]') do i = 1, smearGrid do j = 1, smearGrid do k = 1, smearGridz @@ -143,12 +129,11 @@ contains cellaux(3) = cell(3) + k - (mapCells + 1) if (p == 0) cellaux(3) = 0 - !Check if the cells intended to smear the bubbles in are in the computational domain - !and redefine the cells for symmetric boundary + ! Check if the cells intended to smear the bubbles in are in the computational domain + ! and redefine the cells for symmetric boundary call s_check_celloutside(cellaux, celloutside) if (.not. celloutside) then - nodecoord(1) = x_cc(cellaux(1)) nodecoord(2) = y_cc(cellaux(2)) if (p > 0) nodecoord(3) = z_cc(cellaux(3)) @@ -168,52 +153,45 @@ contains if (p == 0) cellaux(3) = 0 end if - !Update void fraction field + ! Update void fraction field addFun1 = func*strength_vol $:GPU_ATOMIC(atomic='update') - updatedvar(1)%sf(cellaux(1), cellaux(2), cellaux(3)) = & - updatedvar(1)%sf(cellaux(1), cellaux(2), cellaux(3)) & - + real(addFun1, kind=stp) + updatedvar(1)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(1)%sf(cellaux(1), cellaux(2), & + & cellaux(3)) + real(addFun1, kind=stp) - !Update time derivative of void fraction + ! Update time derivative of void fraction addFun2 = func*strength_vel $:GPU_ATOMIC(atomic='update') - updatedvar(2)%sf(cellaux(1), cellaux(2), cellaux(3)) = & - updatedvar(2)%sf(cellaux(1), cellaux(2), cellaux(3)) & - + real(addFun2, kind=stp) + updatedvar(2)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(2)%sf(cellaux(1), cellaux(2), & + & cellaux(3)) + real(addFun2, kind=stp) - !Product of two smeared functions - !Update void fraction * time derivative of void fraction + ! Product of two smeared functions + ! Update void fraction * time derivative of void fraction if (lag_params%cluster_type >= 4) then addFun3 = func2*strength_vol*strength_vel $:GPU_ATOMIC(atomic='update') - updatedvar(5)%sf(cellaux(1), cellaux(2), cellaux(3)) = & - updatedvar(5)%sf(cellaux(1), cellaux(2), cellaux(3)) & - + real(addFun3, kind=stp) + updatedvar(5)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(5)%sf(cellaux(1), cellaux(2), & + & cellaux(3)) + real(addFun3, kind=stp) end if end do end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_gaussian - !> The purpose of this subroutine is to apply the gaussian kernel function for each bubble (Maeda and Colonius, 2018)). subroutine s_applygaussian(center, cellaux, nodecoord, stddsv, strength_idx, func) - $:GPU_ROUTINE(function_name='s_applygaussian',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_applygaussian',parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: center - integer, dimension(3), intent(in) :: cellaux + integer, dimension(3), intent(in) :: cellaux real(wp), dimension(3), intent(in) :: nodecoord - real(wp), intent(in) :: stddsv - real(wp), intent(in) :: strength_idx - real(wp), intent(out) :: func - - real(wp) :: distance - real(wp) :: theta, dtheta, L2, dzp, Lz2 - real(wp) :: Nr, Nr_count + real(wp), intent(in) :: stddsv + real(wp), intent(in) :: strength_idx + real(wp), intent(out) :: func + real(wp) :: distance + real(wp) :: theta, dtheta, L2, dzp, Lz2 + real(wp) :: Nr, Nr_count distance = sqrt((center(1) - nodecoord(1))**2._wp + (center(2) - nodecoord(2))**2._wp + (center(3) - nodecoord(3))**2._wp) @@ -239,8 +217,8 @@ contains L2 = center(2)**2._wp + nodecoord(2)**2._wp - 2._wp*center(2)*nodecoord(2)*cos(theta) distance = sqrt((center(1) - nodecoord(1))**2._wp + L2) ! nodecoord(2)*dtheta is the azimuthal width of the cell - func = func + & - dtheta/2._wp/pi*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv)**(3._wp*(strength_idx + 1._wp)) + func = func + dtheta/2._wp/pi*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv) & + & **(3._wp*(strength_idx + 1._wp)) end do else @@ -257,23 +235,21 @@ contains Nr_count = Nr_count + 1._wp Lz2 = (center(3) - (dzp*(0.5_wp + Nr_count) - lag_params%charwidth/2._wp))**2._wp distance = sqrt((center(1) - nodecoord(1))**2._wp + (center(2) - nodecoord(2))**2._wp + Lz2) - func = func + & - dzp/lag_params%charwidth*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv)**(3._wp*(strength_idx + 1._wp)) + func = func + dzp/lag_params%charwidth*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv) & + & **(3._wp*(strength_idx + 1._wp)) end do end if end if - end subroutine s_applygaussian - - !> The purpose of this subroutine is to check if the current cell is outside the computational domain or not (including ghost cells). + !> The purpose of this subroutine is to check if the current cell is outside the computational domain or not (including ghost + !! cells). !! @param cellaux Tested cell to smear the bubble effect in. !! @param celloutside If true, then cellaux is outside the computational domain. subroutine s_check_celloutside(cellaux, celloutside) - $:GPU_ROUTINE(function_name='s_check_celloutside',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_check_celloutside',parallelism='[seq]', cray_inline=True) integer, dimension(3), intent(inout) :: cellaux - logical, intent(out) :: celloutside + logical, intent(out) :: celloutside celloutside = .false. @@ -296,18 +272,15 @@ contains celloutside = .true. end if end if - end subroutine s_check_celloutside - !> This subroutine relocates the current cell, if it intersects a symmetric boundary. !! @param cell Cell of the current bubble !! @param cellaux Cell to map the bubble effect in. subroutine s_shift_cell_symmetric_bc(cellaux, cell) - $:GPU_ROUTINE(function_name='s_shift_cell_symmetric_bc', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_shift_cell_symmetric_bc', parallelism='[seq]', cray_inline=True) integer, dimension(3), intent(inout) :: cellaux - integer, dimension(3), intent(in) :: cell + integer, dimension(3), intent(in) :: cell ! x-dir if (bc_x%beg == BC_REFLECTIVE .and. (cell(1) <= mapCells - 1)) then @@ -317,7 +290,7 @@ contains cellaux(1) = cellaux(1) - (2*(cellaux(1) - m) - 1) end if - !y-dir + ! y-dir if (bc_y%beg == BC_REFLECTIVE .and. (cell(2) <= mapCells - 1)) then cellaux(2) = abs(cellaux(2)) - 1 end if @@ -326,7 +299,7 @@ contains end if if (p > 0) then - !z-dir + ! z-dir if (bc_z%beg == BC_REFLECTIVE .and. (cell(3) <= mapCells - 1)) then cellaux(3) = abs(cellaux(3)) - 1 end if @@ -334,23 +307,19 @@ contains cellaux(3) = cellaux(3) - (2*(cellaux(3) - p) - 1) end if end if - end subroutine s_shift_cell_symmetric_bc - !> Calculates the standard deviation of the bubble being smeared in the Eulerian framework. !! @param cell Cell where the bubble is located !! @param volpart Volume of the bubble !! @param stddsv Standard deviaton subroutine s_compute_stddsv(cell, volpart, stddsv) - $:GPU_ROUTINE(function_name='s_compute_stddsv',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_stddsv',parallelism='[seq]', cray_inline=True) integer, dimension(3), intent(in) :: cell - real(wp), intent(in) :: volpart - real(wp), intent(out) :: stddsv - - real(wp) :: chardist, charvol - real(wp) :: rad + real(wp), intent(in) :: volpart + real(wp), intent(out) :: stddsv + real(wp) :: chardist, charvol + real(wp) :: rad !< Compute characteristic distance chardist = sqrt(dx(cell(1))*dy(cell(2))) @@ -374,19 +343,16 @@ contains else stddsv = 0._wp end if - end subroutine s_compute_stddsv - !> The purpose of this procedure is to calculate the characteristic cell volume !! @param cellx x-direction cell index !! @param celly y-direction cell index !! @param cellz z-direction cell index !! @param Charvol Characteristic volume subroutine s_get_char_vol(cellx, celly, cellz, Charvol) - $:GPU_ROUTINE(function_name='s_get_char_vol',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_get_char_vol',parallelism='[seq]', cray_inline=True) - integer, intent(in) :: cellx, celly, cellz + integer, intent(in) :: cellx, celly, cellz real(wp), intent(out) :: Charvol if (p > 0) then @@ -398,26 +364,20 @@ contains Charvol = dx(cellx)*dy(celly)*lag_params%charwidth end if end if - end subroutine s_get_char_vol - - !> This subroutine transforms the computational coordinates of the bubble from - !! real type into integer. + !> This subroutine transforms the computational coordinates of the bubble from real type into integer. !! @param s_cell Computational coordinates of the bubble, real type !! @param get_cell Computational coordinates of the bubble, integer type subroutine s_get_cell(s_cell, get_cell) - $:GPU_ROUTINE(function_name='s_get_cell',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_get_cell',parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: s_cell integer, dimension(3), intent(out) :: get_cell - integer :: i + integer :: i get_cell(:) = int(s_cell(:)) do i = 1, num_dims if (s_cell(i) < 0._wp) get_cell(i) = get_cell(i) - 1 end do - end subroutine s_get_cell - end module m_bubbles_EL_kernels diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index f5f9cb4c30..d2cd85cd8c 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -7,7 +7,6 @@ #:include 'macros.fpp' module m_cbc - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -16,12 +15,9 @@ module m_cbc use m_compute_cbc - use m_thermochem, only: & - get_mixture_energy_mass, get_mixture_specific_heat_cv_mass, & - get_mixture_specific_heat_cp_mass, gas_constant, & - get_mixture_molecular_weight, get_species_enthalpies_rt, & - molecular_weights, get_species_specific_heats_r, & - get_mole_fractions, get_species_specific_heats_r + use m_thermochem, only: get_mixture_energy_mass, get_mixture_specific_heat_cv_mass, get_mixture_specific_heat_cp_mass, & + & gas_constant, get_mixture_molecular_weight, get_species_enthalpies_rt, molecular_weights, get_species_specific_heats_r, & + & get_mole_fractions, get_species_specific_heats_r #:if USING_AMD use m_chemistry, only: molecular_weights_nonparameter @@ -34,18 +30,18 @@ module m_cbc !! q_prim_vf in the coordinate direction normal to the domain boundary along !! which the CBC is applied. - real(wp), allocatable, dimension(:, :, :, :) :: q_prim_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: q_prim_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: q_prim_rsz_vf - $:GPU_DECLARE(create='[q_prim_rsx_vf,q_prim_rsy_vf,q_prim_rsz_vf]') + real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsx_vf + real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsy_vf + real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsz_vf + $:GPU_DECLARE(create='[q_prim_rsx_vf, q_prim_rsy_vf, q_prim_rsz_vf]') !! Cell-average fluxes (src - source). These are directly determined from the !! cell-average primitive variables, q_prims_rs_vf, and not a Riemann solver. - real(wp), allocatable, dimension(:, :, :, :) :: F_rsx_vf, F_src_rsx_vf !< - real(wp), allocatable, dimension(:, :, :, :) :: F_rsy_vf, F_src_rsy_vf !< - real(wp), allocatable, dimension(:, :, :, :) :: F_rsz_vf, F_src_rsz_vf !< - $:GPU_DECLARE(create='[F_rsx_vf,F_src_rsx_vf,F_rsy_vf,F_src_rsy_vf,F_rsz_vf,F_src_rsz_vf]') + real(wp), allocatable, dimension(:,:,:,:) :: F_rsx_vf, F_src_rsx_vf !< + real(wp), allocatable, dimension(:,:,:,:) :: F_rsy_vf, F_src_rsy_vf !< + real(wp), allocatable, dimension(:,:,:,:) :: F_rsz_vf, F_src_rsz_vf !< + $:GPU_DECLARE(create='[F_rsx_vf, F_src_rsx_vf, F_rsy_vf, F_src_rsy_vf, F_rsz_vf, F_src_rsz_vf]') !! There is a CCE bug that is causing some subset of these variables to interfere !! with variables of the same name in m_riemann_solvers.fpp, and giving this versions @@ -53,18 +49,18 @@ module m_cbc !! in `acc declare create` clauses don't have this problem, so we still need to !! isolate this bug. - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsx_vf_l, flux_src_rsx_vf_l !< - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsy_vf_l, flux_src_rsy_vf_l - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsz_vf_l, flux_src_rsz_vf_l - $:GPU_DECLARE(create='[flux_rsx_vf_l,flux_src_rsx_vf_l,flux_rsy_vf_l,flux_src_rsy_vf_l,flux_rsz_vf_l,flux_src_rsz_vf_l]') + real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf_l, flux_src_rsx_vf_l !< + real(wp), allocatable, dimension(:,:,:,:) :: flux_rsy_vf_l, flux_src_rsy_vf_l + real(wp), allocatable, dimension(:,:,:,:) :: flux_rsz_vf_l, flux_src_rsz_vf_l + $:GPU_DECLARE(create='[flux_rsx_vf_l, flux_src_rsx_vf_l, flux_rsy_vf_l, flux_src_rsy_vf_l, flux_rsz_vf_l, flux_src_rsz_vf_l]') real(wp), allocatable, dimension(:) :: ds !< Cell-width distribution in the s-direction ! CBC Coefficients - real(wp), allocatable, dimension(:, :) :: fd_coef_x !< Finite diff. coefficients x-dir - real(wp), allocatable, dimension(:, :) :: fd_coef_y !< Finite diff. coefficients y-dir - real(wp), allocatable, dimension(:, :) :: fd_coef_z !< Finite diff. coefficients z-dir + real(wp), allocatable, dimension(:,:) :: fd_coef_x !< Finite diff. coefficients x-dir + real(wp), allocatable, dimension(:,:) :: fd_coef_y !< Finite diff. coefficients y-dir + real(wp), allocatable, dimension(:,:) :: fd_coef_z !< Finite diff. coefficients z-dir !! The first dimension identifies the location of a coefficient in the FD !! formula, while the last dimension denotes the location of the CBC. @@ -72,46 +68,43 @@ module m_cbc ! Bug with NVHPC when using nullified pointers in a declare create ! real(wp), pointer, dimension(:, :) :: fd_coef => null() - real(wp), allocatable, dimension(:, :, :) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir - real(wp), allocatable, dimension(:, :, :) :: pi_coef_y !< Polynomial interpolant coefficients in y-dir - real(wp), allocatable, dimension(:, :, :) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir + real(wp), allocatable, dimension(:,:,:) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir + real(wp), allocatable, dimension(:,:,:) :: pi_coef_y !< Polynomial interpolant coefficients in y-dir + real(wp), allocatable, dimension(:,:,:) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir - $:GPU_DECLARE(create='[ds,fd_coef_x,fd_coef_y,fd_coef_z,pi_coef_x,pi_coef_y,pi_coef_z]') + $:GPU_DECLARE(create='[ds, fd_coef_x, fd_coef_y, fd_coef_z, pi_coef_x, pi_coef_y, pi_coef_z]') !! The first dimension of the array identifies the polynomial, the !! second dimension identifies the position of its coefficients and the last !! dimension denotes the location of the CBC. type(int_bounds_info) :: is1, is2, is3 !< Indical bounds in the s1-, s2- and s3-directions - $:GPU_DECLARE(create='[is1,is2,is3]') + $:GPU_DECLARE(create='[is1, is2, is3]') integer :: dj integer :: bcxb, bcxe, bcyb, bcye, bczb, bcze integer :: cbc_dir, cbc_loc integer :: flux_cbc_index - $:GPU_DECLARE(create='[dj,bcxb,bcxe,bcyb,bcye,bczb,bcze]') - $:GPU_DECLARE(create='[cbc_dir, cbc_loc,flux_cbc_index]') + $:GPU_DECLARE(create='[dj, bcxb, bcxe, bcyb, bcye, bczb, bcze]') + $:GPU_DECLARE(create='[cbc_dir, cbc_loc, flux_cbc_index]') !! GRCBC inputs for subsonic inflow and outflow conditions consisting of !! inflow velocities, pressure, density and void fraction as well as !! outflow velocities and pressure - real(wp), allocatable, dimension(:) :: pres_in, pres_out, Del_in, Del_out - real(wp), allocatable, dimension(:, :) :: vel_in, vel_out - real(wp), allocatable, dimension(:, :) :: alpha_rho_in, alpha_in - $:GPU_DECLARE(create='[pres_in,pres_out,Del_in,Del_out]') - $:GPU_DECLARE(create='[vel_in,vel_out]') - $:GPU_DECLARE(create='[alpha_rho_in,alpha_in]') - + real(wp), allocatable, dimension(:) :: pres_in, pres_out, Del_in, Del_out + real(wp), allocatable, dimension(:,:) :: vel_in, vel_out + real(wp), allocatable, dimension(:,:) :: alpha_rho_in, alpha_in + $:GPU_DECLARE(create='[pres_in, pres_out, Del_in, Del_out]') + $:GPU_DECLARE(create='[vel_in, vel_out]') + $:GPU_DECLARE(create='[alpha_rho_in, alpha_in]') contains - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_cbc_module - - integer :: i - logical :: is_cbc + integer :: i + logical :: is_cbc type(int_bounds_info) :: idx1, idx2 if (chemistry) then @@ -127,7 +120,6 @@ contains if (n == 0) then is2%beg = 0 - else is2%beg = -buff_size end if @@ -136,41 +128,26 @@ contains if (p == 0) then is3%beg = 0 - else is3%beg = -buff_size end if is3%end = p - is3%beg - @:ALLOCATE(q_prim_rsx_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(q_prim_rsx_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) if (weno_order > 1 .or. muscl_order > 1) then + @:ALLOCATE(F_rsx_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:flux_cbc_index)) - @:ALLOCATE(F_rsx_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:flux_cbc_index)) - - @:ALLOCATE(F_src_rsx_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, adv_idx%beg:adv_idx%end)) - + @:ALLOCATE(F_src_rsx_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, adv_idx%beg:adv_idx%end)) end if - @:ALLOCATE(flux_rsx_vf_l(-1:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:flux_cbc_index)) + @:ALLOCATE(flux_rsx_vf_l(-1:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:flux_cbc_index)) - @:ALLOCATE(flux_src_rsx_vf_l(-1:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, adv_idx%beg:adv_idx%end)) + @:ALLOCATE(flux_src_rsx_vf_l(-1:buff_size, is2%beg:is2%end, is3%beg:is3%end, adv_idx%beg:adv_idx%end)) if (n > 0) then - if (m == 0) then is2%beg = 0 - else is2%beg = -buff_size end if @@ -179,43 +156,27 @@ contains if (p == 0) then is3%beg = 0 - else is3%beg = -buff_size end if is3%end = p - is3%beg - @:ALLOCATE(q_prim_rsy_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(q_prim_rsy_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) if (weno_order > 1 .or. muscl_order > 1) then + @:ALLOCATE(F_rsy_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:flux_cbc_index)) - @:ALLOCATE(F_rsy_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:flux_cbc_index)) - - @:ALLOCATE(F_src_rsy_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, adv_idx%beg:adv_idx%end)) - + @:ALLOCATE(F_src_rsy_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, adv_idx%beg:adv_idx%end)) end if - @:ALLOCATE(flux_rsy_vf_l(-1:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:flux_cbc_index)) - - @:ALLOCATE(flux_src_rsy_vf_l(-1:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, adv_idx%beg:adv_idx%end)) + @:ALLOCATE(flux_rsy_vf_l(-1:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:flux_cbc_index)) + @:ALLOCATE(flux_src_rsy_vf_l(-1:buff_size, is2%beg:is2%end, is3%beg:is3%end, adv_idx%beg:adv_idx%end)) end if if (p > 0) then - if (n == 0) then is2%beg = 0 - else is2%beg = -buff_size end if @@ -224,36 +185,22 @@ contains if (m == 0) then is3%beg = 0 - else is3%beg = -buff_size end if is3%end = m - is3%beg - @:ALLOCATE(q_prim_rsz_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(q_prim_rsz_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) if (weno_order > 1 .or. muscl_order > 1) then + @:ALLOCATE(F_rsz_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:flux_cbc_index)) - @:ALLOCATE(F_rsz_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:flux_cbc_index)) - - @:ALLOCATE(F_src_rsz_vf(0:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, adv_idx%beg:adv_idx%end)) - + @:ALLOCATE(F_src_rsz_vf(0:buff_size, is2%beg:is2%end, is3%beg:is3%end, adv_idx%beg:adv_idx%end)) end if - @:ALLOCATE(flux_rsz_vf_l(-1:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:flux_cbc_index)) - - @:ALLOCATE(flux_src_rsz_vf_l(-1:buff_size, & - is2%beg:is2%end, & - is3%beg:is3%end, adv_idx%beg:adv_idx%end)) + @:ALLOCATE(flux_rsz_vf_l(-1:buff_size, is2%beg:is2%end, is3%beg:is3%end, 1:flux_cbc_index)) + @:ALLOCATE(flux_src_rsz_vf_l(-1:buff_size, is2%beg:is2%end, is3%beg:is3%end, adv_idx%beg:adv_idx%end)) end if ! Allocating the cell-width distribution in the s-direction @@ -272,7 +219,6 @@ contains end if ! Allocating/Computing CBC Coefficients in x-direction if (all((/bc_x%beg, bc_x%end/) <= -5) .and. all((/bc_x%beg, bc_x%end/) >= -13)) then - @:ALLOCATE(fd_coef_x(0:buff_size, -1:1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -281,9 +227,7 @@ contains call s_compute_cbc_coefficients(1, -1) call s_compute_cbc_coefficients(1, 1) - - elseif (bc_x%beg <= -5 .and. bc_x%beg >= -13) then - + else if (bc_x%beg <= -5 .and. bc_x%beg >= -13) then @:ALLOCATE(fd_coef_x(0:buff_size, -1:-1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -291,9 +235,7 @@ contains end if call s_compute_cbc_coefficients(1, -1) - - elseif (bc_x%end <= -5 .and. bc_x%end >= -13) then - + else if (bc_x%end <= -5 .and. bc_x%end >= -13) then @:ALLOCATE(fd_coef_x(0:buff_size, 1:1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -301,14 +243,11 @@ contains end if call s_compute_cbc_coefficients(1, 1) - end if ! Allocating/Computing CBC Coefficients in y-direction if (n > 0) then - if (all((/bc_y%beg, bc_y%end/) <= -5) .and. all((/bc_y%beg, bc_y%end/) >= -13)) then - @:ALLOCATE(fd_coef_y(0:buff_size, -1:1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -317,9 +256,7 @@ contains call s_compute_cbc_coefficients(2, -1) call s_compute_cbc_coefficients(2, 1) - - elseif (bc_y%beg <= -5 .and. bc_y%beg >= -13) then - + else if (bc_y%beg <= -5 .and. bc_y%beg >= -13) then @:ALLOCATE(fd_coef_y(0:buff_size, -1:-1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -327,9 +264,7 @@ contains end if call s_compute_cbc_coefficients(2, -1) - - elseif (bc_y%end <= -5 .and. bc_y%end >= -13) then - + else if (bc_y%end <= -5 .and. bc_y%end >= -13) then @:ALLOCATE(fd_coef_y(0:buff_size, 1:1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -337,16 +272,12 @@ contains end if call s_compute_cbc_coefficients(2, 1) - end if - end if ! Allocating/Computing CBC Coefficients in z-direction if (p > 0) then - if (all((/bc_z%beg, bc_z%end/) <= -5) .and. all((/bc_z%beg, bc_z%end/) >= -13)) then - @:ALLOCATE(fd_coef_z(0:buff_size, -1:1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -355,9 +286,7 @@ contains call s_compute_cbc_coefficients(3, -1) call s_compute_cbc_coefficients(3, 1) - - elseif (bc_z%beg <= -5 .and. bc_z%beg >= -13) then - + else if (bc_z%beg <= -5 .and. bc_z%beg >= -13) then @:ALLOCATE(fd_coef_z(0:buff_size, -1:-1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -365,9 +294,7 @@ contains end if call s_compute_cbc_coefficients(3, -1) - - elseif (bc_z%end <= -5 .and. bc_z%end >= -13) then - + else if (bc_z%end <= -5 .and. bc_z%end >= -13) then @:ALLOCATE(fd_coef_z(0:buff_size, 1:1)) if (weno_order > 1 .or. muscl_order > 1) then @@ -375,13 +302,11 @@ contains end if call s_compute_cbc_coefficients(3, 1) - end if - end if $:GPU_UPDATE(device='[fd_coef_x,fd_coef_y,fd_coef_z, & - & pi_coef_x,pi_coef_y,pi_coef_z]') + & pi_coef_x, pi_coef_y, pi_coef_z]') ! Associating the procedural pointer to the appropriate subroutine ! that will be utilized in the conversion to the mixture variables @@ -434,13 +359,11 @@ contains end do end if #:endfor - $:GPU_UPDATE(device='[vel_in,vel_out,pres_in,pres_out,Del_in,Del_out,alpha_rho_in,alpha_in]') - + $:GPU_UPDATE(device='[vel_in, vel_out, pres_in, pres_out, Del_in, Del_out, alpha_rho_in, alpha_in]') end subroutine s_initialize_cbc_module - - !> Compute CBC coefficients - !! @param cbc_dir_in CBC coordinate direction - !! @param cbc_loc_in CBC coordinate location + !> Compute CBC coefficients + !! @param cbc_dir_in CBC coordinate direction + !! @param cbc_loc_in CBC coordinate location subroutine s_compute_cbc_coefficients(cbc_dir_in, cbc_loc_in) ! Description: The purpose of this subroutine is to compute the grid ! dependent FD and PI coefficients, or CBC coefficients, @@ -469,14 +392,12 @@ contains #:for CBC_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (cbc_dir_in == ${CBC_DIR}$ .and. recon_type == WENO_TYPE) then if (weno_order == 1) then - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp fd_coef_${XYZ}$ (0, cbc_loc_in) = -2._wp/(ds(0) + ds(1)) fd_coef_${XYZ}$ (1, cbc_loc_in) = -fd_coef_${XYZ}$ (0, cbc_loc_in) ! Computing CBC2 Coefficients - elseif (weno_order == 3) then - + else if (weno_order == 3) then fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp fd_coef_${XYZ}$ (0, cbc_loc_in) = -6._wp/(3._wp*ds(0) + 2._wp*ds(1) - ds(2)) fd_coef_${XYZ}$ (1, cbc_loc_in) = -4._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/3._wp @@ -488,47 +409,35 @@ contains else fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp - fd_coef_${XYZ}$ (0, cbc_loc_in) = -50._wp/(25._wp*ds(0) + 2._wp*ds(1) & - - 1.e1_wp*ds(2) + 1.e1_wp*ds(3) & - - 3._wp*ds(4)) + fd_coef_${XYZ}$ (0, & + & cbc_loc_in) = -50._wp/(25._wp*ds(0) + 2._wp*ds(1) - 1.e1_wp*ds(2) + 1.e1_wp*ds(3) & + & - 3._wp*ds(4)) fd_coef_${XYZ}$ (1, cbc_loc_in) = -48._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (2, cbc_loc_in) = 36._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (3, cbc_loc_in) = -16._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (4, cbc_loc_in) = 3._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp - pi_coef_${XYZ}$ (0, 0, cbc_loc_in) = & - ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))* & - (s_cb(1) - s_cb(3)))/((s_cb(1) - s_cb(4))* & - (s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) - pi_coef_${XYZ}$ (0, 1, cbc_loc_in) = & - ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))* & - ((s_cb(1) - s_cb(3))*(s_cb(1) - s_cb(3)) - & - (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + & - (s_cb(4) - s_cb(1)))))/ & - ((s_cb(0) - s_cb(3))*(s_cb(1) - s_cb(3))* & - (s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) - pi_coef_${XYZ}$ (0, 2, cbc_loc_in) = & - (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))* & - (s_cb(1) - s_cb(3)) + ((s_cb(0) - s_cb(2)) + & - (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/ & - ((s_cb(2) - s_cb(0))*(s_cb(0) - s_cb(3))* & - (s_cb(0) - s_cb(4))) - pi_coef_${XYZ}$ (1, 0, cbc_loc_in) = & - ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))* & - (s_cb(2) - s_cb(3)))/((s_cb(2) - s_cb(4))* & - (s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) - pi_coef_${XYZ}$ (1, 1, cbc_loc_in) = & - ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))* & - ((s_cb(1) - s_cb(3))*(s_cb(2) - s_cb(3)) + & - (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + & - (s_cb(2) - s_cb(4)))))/ & - ((s_cb(0) - s_cb(3))*(s_cb(1) - s_cb(3))* & - (s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) - pi_coef_${XYZ}$ (1, 2, cbc_loc_in) = & - ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))* & - (s_cb(2) - s_cb(4)))/((s_cb(0) - s_cb(2))* & - (s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) - + pi_coef_${XYZ}$ (0, 0, & + & cbc_loc_in) = ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)))/((s_cb(1) & + & - s_cb(4))*(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) + pi_coef_${XYZ}$ (0, 1, & + & cbc_loc_in) = ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(1) & + & - s_cb(3)) - (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + (s_cb(4) - s_cb(1)))))/((s_cb(0) & + & - s_cb(3))*(s_cb(1) - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) + pi_coef_${XYZ}$ (0, 2, & + & cbc_loc_in) = (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)) + ((s_cb(0) & + & - s_cb(2)) + (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/((s_cb(2) - s_cb(0))*(s_cb(0) & + & - s_cb(3))*(s_cb(0) - s_cb(4))) + pi_coef_${XYZ}$ (1, 0, & + & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))*(s_cb(2) - s_cb(3)))/((s_cb(2) & + & - s_cb(4))*(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) + pi_coef_${XYZ}$ (1, 1, & + & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(2) & + & - s_cb(3)) + (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + (s_cb(2) - s_cb(4)))))/((s_cb(0) & + & - s_cb(3))*(s_cb(1) - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) + pi_coef_${XYZ}$ (1, 2, & + & cbc_loc_in) = ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))*(s_cb(2) - s_cb(4)))/((s_cb(0) & + & - s_cb(2))*(s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) end if end if #:endfor @@ -536,26 +445,19 @@ contains ! END: Computing CBC4 Coefficients ! Nullifying CBC coefficients - end subroutine s_compute_cbc_coefficients - - !> @brief Associates finite-difference and polynomial-interpolation CBC coefficients with targets based on coordinate direction and boundary location. - !! The goal of the procedure is to associate the FD and PI - !! coefficients, or CBC coefficients, with the appropriate - !! targets, based on the coordinate direction and location - !! of the CBC. - !! @param cbc_dir_in CBC coordinate direction - !! @param cbc_loc_in CBC coordinate location + !> @brief Associates finite-difference and polynomial-interpolation CBC coefficients with targets based on coordinate direction + !! and boundary location. The goal of the procedure is to associate the FD and PI coefficients, or CBC coefficients, with the + !! appropriate targets, based on the coordinate direction and location of the CBC. + !! @param cbc_dir_in CBC coordinate direction + !! @param cbc_loc_in CBC coordinate location subroutine s_associate_cbc_coefficients_pointers(cbc_dir_in, cbc_loc_in) - integer, intent(in) :: cbc_dir_in, cbc_loc_in - - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator ! Associating CBC Coefficients in x-direction if (cbc_dir_in == 1) then - - !fd_coef => fd_coef_x; if (weno_order > 1) pi_coef => pi_coef_x + ! fd_coef => fd_coef_x; if (weno_order > 1) pi_coef => pi_coef_x if (cbc_loc_in == -1) then do i = 0, buff_size @@ -568,9 +470,8 @@ contains end if ! Associating CBC Coefficients in y-direction - elseif (cbc_dir_in == 2) then - - !fd_coef => fd_coef_y; if (weno_order > 1) pi_coef => pi_coef_y + else if (cbc_dir_in == 2) then + ! fd_coef => fd_coef_y; if (weno_order > 1) pi_coef => pi_coef_y if (cbc_loc_in == -1) then do i = 0, buff_size @@ -585,7 +486,7 @@ contains ! Associating CBC Coefficients in z-direction else - !fd_coef => fd_coef_z; if (weno_order > 1) pi_coef => pi_coef_z + ! fd_coef => fd_coef_z; if (weno_order > 1) pi_coef => pi_coef_z if (cbc_loc_in == -1) then do i = 0, buff_size @@ -596,87 +497,69 @@ contains ds(i) = dz(p - i) end do end if - end if $:GPU_UPDATE(device='[ds]') - end subroutine s_associate_cbc_coefficients_pointers - - !> The following is the implementation of the CBC based on - !! the work of Thompson (1987, 1990) on hyperbolic systems. - !! The CBC is indirectly applied in the computation of the - !! right-hand-side (RHS) near the relevant domain boundary - !! through the modification of the fluxes. - !! @param q_prim_vf Cell-average primitive variables - !! @param flux_vf Cell-boundary-average fluxes - !! @param flux_src_vf Cell-boundary-average flux sources - !! @param cbc_dir_norm CBC coordinate direction - !! @param cbc_loc_norm CBC coordinate location - !! @param ix Index bound in the first coordinate direction - !! @param iy Index bound in the second coordinate direction - !! @param iz Index bound in the third coordinate direction - subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, & - cbc_dir_norm, cbc_loc_norm, & - ix, iy, iz) - - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_prim_vf - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf - - integer, intent(in) :: cbc_dir_norm, cbc_loc_norm - - type(int_bounds_info), intent(in) :: ix, iy, iz - real(wp) :: drho_dt - real(wp) :: dpres_dt - real(wp) :: dgamma_dt - real(wp) :: dpi_inf_dt - real(wp) :: dqv_dt - real(wp) :: dpres_ds + !> The following is the implementation of the CBC based on the work of Thompson (1987, 1990) on hyperbolic systems. The CBC is + !! indirectly applied in the computation of the right-hand-side (RHS) near the relevant domain boundary through the modification + !! of the fluxes. + !! @param q_prim_vf Cell-average primitive variables + !! @param flux_vf Cell-boundary-average fluxes + !! @param flux_src_vf Cell-boundary-average flux sources + !! @param cbc_dir_norm CBC coordinate direction + !! @param cbc_loc_norm CBC coordinate location + !! @param ix Index bound in the first coordinate direction + !! @param iy Index bound in the second coordinate direction + !! @param iz Index bound in the third coordinate direction + subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, cbc_dir_norm, cbc_loc_norm, ix, iy, iz) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf + integer, intent(in) :: cbc_dir_norm, cbc_loc_norm + type(int_bounds_info), intent(in) :: ix, iy, iz + real(wp) :: drho_dt + real(wp) :: dpres_dt + real(wp) :: dgamma_dt + real(wp) :: dpi_inf_dt + real(wp) :: dqv_dt + real(wp) :: dpres_ds #:if USING_AMD real(wp), dimension(20) :: L #:else real(wp), dimension(sys_size) :: L #:endif #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha_rho, dalpha_rho_ds, mf - real(wp), dimension(3) :: vel, dvel_ds - real(wp), dimension(3) :: adv_local, dadv_ds - real(wp), dimension(3) :: dadv_dt - real(wp), dimension(3) :: dvel_dt - real(wp), dimension(3) :: dalpha_rho_dt + real(wp), dimension(3) :: alpha_rho, dalpha_rho_ds, mf + real(wp), dimension(3) :: vel, dvel_ds + real(wp), dimension(3) :: adv_local, dadv_ds + real(wp), dimension(3) :: dadv_dt + real(wp), dimension(3) :: dvel_dt + real(wp), dimension(3) :: dalpha_rho_dt real(wp), dimension(10) :: Ys, h_k, dYs_dt, dYs_ds, Xs, Gamma_i, Cp_i #:else - real(wp), dimension(num_fluids) :: alpha_rho, dalpha_rho_ds, mf - real(wp), dimension(num_vels) :: vel, dvel_ds - real(wp), dimension(num_fluids) :: adv_local, dadv_ds - real(wp), dimension(num_fluids) :: dadv_dt - real(wp), dimension(num_dims) :: dvel_dt - real(wp), dimension(num_fluids) :: dalpha_rho_dt + real(wp), dimension(num_fluids) :: alpha_rho, dalpha_rho_ds, mf + real(wp), dimension(num_vels) :: vel, dvel_ds + real(wp), dimension(num_fluids) :: adv_local, dadv_ds + real(wp), dimension(num_fluids) :: dadv_dt + real(wp), dimension(num_dims) :: dvel_dt + real(wp), dimension(num_fluids) :: dalpha_rho_dt real(wp), dimension(num_species) :: Ys, h_k, dYs_dt, dYs_ds, Xs, Gamma_i, Cp_i #:endif real(wp), dimension(2) :: Re_cbc real(wp), dimension(3) :: lambda - - real(wp) :: rho !< Cell averaged density - real(wp) :: pres !< Cell averaged pressure - real(wp) :: E !< Cell averaged energy - real(wp) :: H !< Cell averaged enthalpy - real(wp) :: gamma !< Cell averaged specific heat ratio - real(wp) :: pi_inf !< Cell averaged liquid stiffness - real(wp) :: qv !< Cell averaged fluid reference energy - real(wp) :: c - real(wp) :: Ma - real(wp) :: T, sum_Enthalpies - real(wp) :: Cv, Cp, e_mix, Mw, R_gas - - real(wp) :: vel_K_sum, vel_dv_dt_sum - - integer :: i, j, k, r !< Generic loop iterators + real(wp) :: rho !< Cell averaged density + real(wp) :: pres !< Cell averaged pressure + real(wp) :: E !< Cell averaged energy + real(wp) :: H !< Cell averaged enthalpy + real(wp) :: gamma !< Cell averaged specific heat ratio + real(wp) :: pi_inf !< Cell averaged liquid stiffness + real(wp) :: qv !< Cell averaged fluid reference energy + real(wp) :: c + real(wp) :: Ma + real(wp) :: T, sum_Enthalpies + real(wp) :: Cv, Cp, e_mix, Mw, R_gas + real(wp) :: vel_K_sum, vel_dv_dt_sum + integer :: i, j, k, r !< Generic loop iterators ! Reshaping of inputted data and association of the FD and PI ! coefficients, or CBC coefficients, respectively, hinging on @@ -687,43 +570,34 @@ contains $:GPU_UPDATE(device='[cbc_dir, cbc_loc]') - call s_initialize_cbc(q_prim_vf, flux_vf, flux_src_vf, & - ix, iy, iz) + call s_initialize_cbc(q_prim_vf, flux_vf, flux_src_vf, ix, iy, iz) call s_associate_cbc_coefficients_pointers(cbc_dir, cbc_loc) #:for CBC_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (cbc_dir == ${CBC_DIR}$ .and. recon_type == WENO_TYPE) then - ! PI2 of flux_rs_vf and flux_src_rs_vf at j = 1/2 if (weno_order == 3 .or. dummy) then + call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, F_rs${XYZ}$_vf, F_src_rs${XYZ}$_vf, is1, is2, & + & is3, idwbuff(2)%beg, idwbuff(3)%beg) - call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, & - F_rs${XYZ}$_vf, & - F_src_rs${XYZ}$_vf, & - is1, is2, is3, idwbuff(2)%beg, idwbuff(3)%beg) - - $:GPU_PARALLEL_LOOP(private='[i,r,k]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, r, k]', collapse=3) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end - flux_rs${XYZ}$_vf_l(0, k, r, i) = F_rs${XYZ}$_vf(0, k, r, i) & - + pi_coef_${XYZ}$ (0, 0, cbc_loc)* & - (F_rs${XYZ}$_vf(1, k, r, i) - & - F_rs${XYZ}$_vf(0, k, r, i)) + flux_rs${XYZ}$_vf_l(0, k, r, i) = F_rs${XYZ}$_vf(0, k, r, i) + pi_coef_${XYZ}$ (0, 0, & + & cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, i) - F_rs${XYZ}$_vf(0, k, r, i)) end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[i,r,k]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, r, k]', collapse=3) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end - flux_src_rs${XYZ}$_vf_l(0, k, r, i) = F_src_rs${XYZ}$_vf(0, k, r, i) + & - (F_src_rs${XYZ}$_vf(1, k, r, i) - & - F_src_rs${XYZ}$_vf(0, k, r, i)) & - *pi_coef_${XYZ}$ (0, 0, cbc_loc) + flux_src_rs${XYZ}$_vf_l(0, k, r, i) = F_src_rs${XYZ}$_vf(0, k, r, i) + (F_src_rs${XYZ}$_vf(1, k, & + & r, i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (0, 0, cbc_loc) end do end do end do @@ -732,60 +606,50 @@ contains ! PI4 of flux_rs_vf and flux_src_rs_vf at j = 1/2, 3/2 if (weno_order == 5 .or. dummy) then - call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, & - F_rs${XYZ}$_vf, & - F_src_rs${XYZ}$_vf, & - is1, is2, is3, idwbuff(2)%beg, idwbuff(3)%beg) + call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, F_rs${XYZ}$_vf, F_src_rs${XYZ}$_vf, is1, is2, & + & is3, idwbuff(2)%beg, idwbuff(3)%beg) - $:GPU_PARALLEL_LOOP(private='[i,j,r,k]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, r, k]', collapse=4) do i = 1, flux_cbc_index do j = 0, 1 do r = is3%beg, is3%end do k = is2%beg, is2%end - flux_rs${XYZ}$_vf_l(j, k, r, i) = F_rs${XYZ}$_vf(j, k, r, i) & - + pi_coef_${XYZ}$ (j, 0, cbc_loc)* & - (F_rs${XYZ}$_vf(3, k, r, i) - & - F_rs${XYZ}$_vf(2, k, r, i)) & - + pi_coef_${XYZ}$ (j, 1, cbc_loc)* & - (F_rs${XYZ}$_vf(2, k, r, i) - & - F_rs${XYZ}$_vf(1, k, r, i)) & - + pi_coef_${XYZ}$ (j, 2, cbc_loc)* & - (F_rs${XYZ}$_vf(1, k, r, i) - & - F_rs${XYZ}$_vf(0, k, r, i)) + flux_rs${XYZ}$_vf_l(j, k, r, i) = F_rs${XYZ}$_vf(j, k, r, i) + pi_coef_${XYZ}$ (j, 0, & + & cbc_loc)*(F_rs${XYZ}$_vf(3, k, r, i) - F_rs${XYZ}$_vf(2, k, r, & + & i)) + pi_coef_${XYZ}$ (j, 1, cbc_loc)*(F_rs${XYZ}$_vf(2, k, r, & + & i) - F_rs${XYZ}$_vf(1, k, r, i)) + pi_coef_${XYZ}$ (j, 2, & + & cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, i) - F_rs${XYZ}$_vf(0, k, r, i)) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[i,j,r,k]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, r, k]', collapse=4) do i = advxb, advxe do j = 0, 1 do r = is3%beg, is3%end do k = is2%beg, is2%end - flux_src_rs${XYZ}$_vf_l(j, k, r, i) = F_src_rs${XYZ}$_vf(j, k, r, i) + & - (F_src_rs${XYZ}$_vf(3, k, r, i) - & - F_src_rs${XYZ}$_vf(2, k, r, i)) & - *pi_coef_${XYZ}$ (j, 0, cbc_loc) + & - (F_src_rs${XYZ}$_vf(2, k, r, i) - & - F_src_rs${XYZ}$_vf(1, k, r, i)) & - *pi_coef_${XYZ}$ (j, 1, cbc_loc) + & - (F_src_rs${XYZ}$_vf(1, k, r, i) - & - F_src_rs${XYZ}$_vf(0, k, r, i)) & - *pi_coef_${XYZ}$ (j, 2, cbc_loc) + flux_src_rs${XYZ}$_vf_l(j, k, r, i) = F_src_rs${XYZ}$_vf(j, k, r, i) + (F_src_rs${XYZ}$_vf(3, & + & k, r, i) - F_src_rs${XYZ}$_vf(2, k, r, i))*pi_coef_${XYZ}$ (j, 0, & + & cbc_loc) + (F_src_rs${XYZ}$_vf(2, k, r, i) - F_src_rs${XYZ}$_vf(1, & + & k, r, i))*pi_coef_${XYZ}$ (j, 1, cbc_loc) + (F_src_rs${XYZ}$_vf(1, & + & k, r, i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (j, 2, & + & cbc_loc) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - end if ! FD2 or FD4 of RHS at j = 0 - $:GPU_PARALLEL_LOOP(collapse=2, private='[r,k,alpha_rho, vel, adv_local, mf, dvel_ds, dadv_ds, Re_cbc, dalpha_rho_ds, dpres_ds, dvel_dt, dadv_dt, dalpha_rho_dt, L, lambda, Ys, dYs_dt, dYs_ds, h_k, Cp_i, Gamma_i, Xs, drho_dt, dpres_dt, dpi_inf_dt, dqv_dt, dgamma_dt, rho, pres, E, H, gamma, pi_inf, qv, c, Ma, T, sum_Enthalpies, Cv, Cp, e_mix, Mw, R_gas, vel_K_sum, vel_dv_dt_sum, i, j]', copyin='[dir_idx]') + $:GPU_PARALLEL_LOOP(collapse=2, private='[r, k, alpha_rho, vel, adv_local, mf, dvel_ds, dadv_ds, Re_cbc, & + & dalpha_rho_ds, dpres_ds, dvel_dt, dadv_dt, dalpha_rho_dt, L, lambda, Ys, dYs_dt, dYs_ds, h_k, Cp_i, Gamma_i, & + & Xs, drho_dt, dpres_dt, dpi_inf_dt, dqv_dt, dgamma_dt, rho, pres, E, H, gamma, pi_inf, qv, c, Ma, T, & + & sum_Enthalpies, Cv, Cp, e_mix, Mw, R_gas, vel_K_sum, vel_dv_dt_sum, i, j]', copyin='[dir_idx]') do r = is3%beg, is3%end do k = is2%beg, is2%end - ! Transferring the Primitive Variables $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe @@ -876,36 +740,26 @@ contains $:GPU_LOOP(parallelism='[seq]') do j = 0, buff_size - $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - dalpha_rho_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, i)* & - fd_coef_${XYZ}$ (j, cbc_loc) + & - dalpha_rho_ds(i) + dalpha_rho_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, i)*fd_coef_${XYZ}$ (j, cbc_loc) + dalpha_rho_ds(i) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - dvel_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, contxe + i)* & - fd_coef_${XYZ}$ (j, cbc_loc) + & - dvel_ds(i) + dvel_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, contxe + i)*fd_coef_${XYZ}$ (j, cbc_loc) + dvel_ds(i) end do - dpres_ds = q_prim_rs${XYZ}$_vf(j, k, r, E_idx)* & - fd_coef_${XYZ}$ (j, cbc_loc) + & - dpres_ds + dpres_ds = q_prim_rs${XYZ}$_vf(j, k, r, E_idx)*fd_coef_${XYZ}$ (j, cbc_loc) + dpres_ds $:GPU_LOOP(parallelism='[seq]') do i = 1, advxe - E_idx - dadv_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, E_idx + i)* & - fd_coef_${XYZ}$ (j, cbc_loc) + & - dadv_ds(i) + dadv_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, E_idx + i)*fd_coef_${XYZ}$ (j, cbc_loc) + dadv_ds(i) end do if (chemistry) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_species - dYs_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, chemxb - 1 + i)* & - fd_coef_${XYZ}$ (j, cbc_loc) + & - dYs_ds(i) + dYs_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, chemxb - 1 + i)*fd_coef_${XYZ}$ (j, & + & cbc_loc) + dYs_ds(i) end do end if end do @@ -917,20 +771,22 @@ contains Ma = vel(dir_idx(1))/c - if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SLIP_WALL) .or. & - (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SLIP_WALL)) then + if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SLIP_WALL) & + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SLIP_WALL)) then call s_compute_slip_wall_L(lambda, L, rho, c, dpres_ds, dvel_ds) - else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_BUFFER) .or. & - (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_BUFFER)) then - call s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) - else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_INFLOW) .or. & - (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_INFLOW)) then + else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_BUFFER) & + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_BUFFER)) then + call s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & + & dvel_ds, dadv_ds, dYs_ds) + else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_INFLOW) & + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_INFLOW)) then call s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, dpres_ds, dvel_ds) ! Add GRCBC for Subsonic Inflow if (bc_${XYZ}$%grcbc_in) then $:GPU_LOOP(parallelism='[seq]') do i = 2, momxb - L(i) = c**3._wp*Ma*(alpha_rho(i - 1) - alpha_rho_in(i - 1, ${CBC_DIR}$))/Del_in(${CBC_DIR}$) - c*Ma*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) + L(i) = c**3._wp*Ma*(alpha_rho(i - 1) - alpha_rho_in(i - 1, & + & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) - c*Ma*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) end do if (n > 0) then L(momxb + 1) = c*Ma*(vel(dir_idx(2)) - vel_in(${CBC_DIR}$, dir_idx(2)))/Del_in(${CBC_DIR}$) @@ -940,56 +796,59 @@ contains end if $:GPU_LOOP(parallelism='[seq]') do i = E_idx, advxe - 1 - L(i) = c*Ma*(adv_local(i + 1 - E_idx) - alpha_in(i + 1 - E_idx, ${CBC_DIR}$))/Del_in(${CBC_DIR}$) + L(i) = c*Ma*(adv_local(i + 1 - E_idx) - alpha_in(i + 1 - E_idx, & + & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) end do - L(advxe) = rho*c**2._wp*(1._wp + Ma)*(vel(dir_idx(1)) + vel_in(${CBC_DIR}$, dir_idx(1))*sign(1, cbc_loc))/Del_in(${CBC_DIR}$) + c*(1._wp + Ma)*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) + L(advxe) = rho*c**2._wp*(1._wp + Ma)*(vel(dir_idx(1)) + vel_in(${CBC_DIR}$, dir_idx(1))*sign(1, & + & cbc_loc))/Del_in(${CBC_DIR}$) + c*(1._wp + Ma)*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) end if - else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_OUTFLOW) .or. & - (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_OUTFLOW)) then - call s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) + else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_OUTFLOW) & + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_OUTFLOW)) then + call s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & + & dvel_ds, dadv_ds, dYs_ds) ! Add GRCBC for Subsonic Outflow (Pressure) if (bc_${XYZ}$%grcbc_out) then L(advxe) = c*(1._wp - Ma)*(pres - pres_out(${CBC_DIR}$))/Del_out(${CBC_DIR}$) ! Add GRCBC for Subsonic Outflow (Normal Velocity) if (bc_${XYZ}$%grcbc_vel_out) then - L(advxe) = L(advxe) + rho*c**2._wp*(1._wp - Ma)*(vel(dir_idx(1)) + vel_out(${CBC_DIR}$, dir_idx(1))*sign(1, cbc_loc))/Del_out(${CBC_DIR}$) + L(advxe) = L(advxe) + rho*c**2._wp*(1._wp - Ma)*(vel(dir_idx(1)) + vel_out(${CBC_DIR}$, & + & dir_idx(1))*sign(1, cbc_loc))/Del_out(${CBC_DIR}$) end if end if - else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_FF_SUB_OUTFLOW) .or. & - (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_FF_SUB_OUTFLOW)) then - call s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) - else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_CP_SUB_OUTFLOW) .or. & - (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_CP_SUB_OUTFLOW)) then - call s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) - else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_INFLOW) .or. & - (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_INFLOW)) then + else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_FF_SUB_OUTFLOW) & + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_FF_SUB_OUTFLOW)) then + call s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, & + & dadv_ds) + else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_CP_SUB_OUTFLOW) & + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_CP_SUB_OUTFLOW)) then + call s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & + & dvel_ds, dadv_ds) + else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_INFLOW) & + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_INFLOW)) then call s_compute_supersonic_inflow_L(L) - else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_OUTFLOW) .or. & - (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_OUTFLOW)) then - call s_compute_supersonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) + else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_OUTFLOW) & + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_OUTFLOW)) then + call s_compute_supersonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, & + & dYs_ds) end if ! Be careful about the cylindrical coordinate! if (cyl_coord .and. cbc_dir == 2 .and. cbc_loc == 1) then - dpres_dt = -5.e-1_wp*(L(advxe) + L(1)) + rho*c*c*vel(dir_idx(1)) & - /y_cc(n) + dpres_dt = -5.e-1_wp*(L(advxe) + L(1)) + rho*c*c*vel(dir_idx(1))/y_cc(n) else dpres_dt = -5.e-1_wp*(L(advxe) + L(1)) end if $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - dalpha_rho_dt(i) = & - -(L(i + 1) - mf(i)*dpres_dt)/(c*c) + dalpha_rho_dt(i) = -(L(i + 1) - mf(i)*dpres_dt)/(c*c) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - dvel_dt(dir_idx(i)) = dir_flg(dir_idx(i))* & - (L(1) - L(advxe))/(2._wp*rho*c) + & - (dir_flg(dir_idx(i)) - 1._wp)* & - L(momxb + i - 1) + dvel_dt(dir_idx(i)) = dir_flg(dir_idx(i))*(L(1) - L(advxe))/(2._wp*rho*c) + (dir_flg(dir_idx(i)) & + & - 1._wp)*L(momxb + i - 1) end do vel_dv_dt_sum = 0._wp @@ -1009,7 +868,7 @@ contains if (cyl_coord .and. cbc_dir == 2 .and. cbc_loc == 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, advxe - E_idx - dadv_dt(i) = -L(momxe + i) !+ adv_local(i) * vel(dir_idx(1))/y_cc(n) + dadv_dt(i) = -L(momxe + i) ! + adv_local(i) * vel(dir_idx(1))/y_cc(n) end do else $:GPU_LOOP(parallelism='[seq]') @@ -1039,47 +898,43 @@ contains ! flux_rs_vf_l and flux_src_rs_vf_l at j = -1/2 $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, i) & - + ds(0)*dalpha_rho_dt(i) + flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, i) + ds(0)*dalpha_rho_dt(i) end do $:GPU_LOOP(parallelism='[seq]') do i = momxb, momxe - flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, i) & - + ds(0)*(vel(i - contxe)*drho_dt & - + rho*dvel_dt(i - contxe)) + flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, & + & i) + ds(0)*(vel(i - contxe)*drho_dt + rho*dvel_dt(i - contxe)) end do if (chemistry) then - ! Evolution of LODI equation of energy for real gases adjusted to perfect gas, doi:10.1006/jcph.2002.6990 + ! Evolution of LODI equation of energy for real gases adjusted to perfect gas, + ! doi:10.1006/jcph.2002.6990 call get_species_enthalpies_rt(T, h_k) sum_Enthalpies = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_species - #:if USING_AMD h_k(i) = h_k(i)*gas_constant/molecular_weights_nonparameter(i)*T - sum_Enthalpies = sum_Enthalpies + (rho*h_k(i) - pres*Mw/molecular_weights_nonparameter(i)*Cp/R_gas)*dYs_dt(i) + sum_Enthalpies = sum_Enthalpies + (rho*h_k(i) - pres*Mw/molecular_weights_nonparameter(i) & + & *Cp/R_gas)*dYs_dt(i) #:else h_k(i) = h_k(i)*gas_constant/molecular_weights(i)*T sum_Enthalpies = sum_Enthalpies + (rho*h_k(i) - pres*Mw/molecular_weights(i)*Cp/R_gas)*dYs_dt(i) #:endif end do - flux_rs${XYZ}$_vf_l(-1, k, r, E_idx) = flux_rs${XYZ}$_vf_l(0, k, r, E_idx) & - + ds(0)*((E/rho + pres/rho)*drho_dt + rho*vel_dv_dt_sum + Cp*T*L(2)/(c*c) + sum_Enthalpies) + flux_rs${XYZ}$_vf_l(-1, k, r, E_idx) = flux_rs${XYZ}$_vf_l(0, k, r, & + & E_idx) + ds(0)*((E/rho + pres/rho)*drho_dt + rho*vel_dv_dt_sum + Cp*T*L(2)/(c*c) & + & + sum_Enthalpies) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_species - flux_rs${XYZ}$_vf_l(-1, k, r, i - 1 + chemxb) = flux_rs${XYZ}$_vf_l(0, k, r, chemxb + i - 1) & - + ds(0)*(drho_dt*Ys(i) + rho*dYs_dt(i)) + flux_rs${XYZ}$_vf_l(-1, k, r, i - 1 + chemxb) = flux_rs${XYZ}$_vf_l(0, k, r, & + & chemxb + i - 1) + ds(0)*(drho_dt*Ys(i) + rho*dYs_dt(i)) end do else - flux_rs${XYZ}$_vf_l(-1, k, r, E_idx) = flux_rs${XYZ}$_vf_l(0, k, r, E_idx) & - + ds(0)*(pres*dgamma_dt & - + gamma*dpres_dt & - + dpi_inf_dt & - + dqv_dt & - + rho*vel_dv_dt_sum & - + 5.e-1_wp*drho_dt*vel_K_sum) + flux_rs${XYZ}$_vf_l(-1, k, r, E_idx) = flux_rs${XYZ}$_vf_l(0, k, r, & + & E_idx) + ds(0)*(pres*dgamma_dt + gamma*dpres_dt + dpi_inf_dt + dqv_dt & + & + rho*vel_dv_dt_sum + 5.e-1_wp*drho_dt*vel_K_sum) end if if (riemann_solver == 1) then @@ -1090,31 +945,24 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - flux_src_rs${XYZ}$_vf_l(-1, k, r, i) = & - 1._wp/max(abs(vel(dir_idx(1))), sgm_eps) & - *sign(1._wp, vel(dir_idx(1))) & - *(flux_rs${XYZ}$_vf_l(0, k, r, i) & - + vel(dir_idx(1)) & - *flux_src_rs${XYZ}$_vf_l(0, k, r, i) & - + ds(0)*dadv_dt(i - E_idx)) + flux_src_rs${XYZ}$_vf_l(-1, k, r, i) = 1._wp/max(abs(vel(dir_idx(1))), sgm_eps)*sign(1._wp, & + & vel(dir_idx(1)))*(flux_rs${XYZ}$_vf_l(0, k, r, & + & i) + vel(dir_idx(1))*flux_src_rs${XYZ}$_vf_l(0, k, r, & + & i) + ds(0)*dadv_dt(i - E_idx)) end do - else $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, i) + & - ds(0)*dadv_dt(i - E_idx) + flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, i) + ds(0)*dadv_dt(i - E_idx) end do $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_src_rs${XYZ}$_vf_l(-1, k, r, i) = flux_src_rs${XYZ}$_vf_l(0, k, r, i) end do - end if ! END: flux_rs_vf_l and flux_src_rs_vf_l at j = -1/2 - end do end do $:END_GPU_PARALLEL_LOOP() @@ -1128,31 +976,19 @@ contains ! CBC coordinate direction. call s_finalize_cbc(flux_vf, flux_src_vf) end subroutine s_cbc - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are required for the setup of the - !! selected CBC. - !! @param q_prim_vf Cell-average primitive variables - !! @param flux_vf Cell-boundary-average fluxes - !! @param flux_src_vf Cell-boundary-average flux sources - !! @param ix Index bound in the first coordinate direction - !! @param iy Index bound in the second coordinate direction - !! @param iz Index bound in the third coordinate direction - subroutine s_initialize_cbc(q_prim_vf, flux_vf, flux_src_vf, & - ix, iy, iz) - - type(scalar_field), & - dimension(sys_size), & - intent(in) :: q_prim_vf - - type(scalar_field), & - dimension(sys_size), & - intent(in) :: flux_vf, flux_src_vf - - type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: i, j, k, r !< Generic loop iterators + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are required for the setup of the selected CBC. + !! @param q_prim_vf Cell-average primitive variables + !! @param flux_vf Cell-boundary-average fluxes + !! @param flux_src_vf Cell-boundary-average flux sources + !! @param ix Index bound in the first coordinate direction + !! @param iy Index bound in the second coordinate direction + !! @param iz Index bound in the third coordinate direction + subroutine s_initialize_cbc(q_prim_vf, flux_vf, flux_src_vf, ix, iy, iz) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(in) :: flux_vf, flux_src_vf + type(int_bounds_info), intent(in) :: ix, iy, iz + integer :: i, j, k, r !< Generic loop iterators ! Configuring the coordinate direction indexes and flags @@ -1163,7 +999,7 @@ contains if (cbc_dir == 1) then is1%beg = 0; is1%end = buff_size; is2 = iy; is3 = iz dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) - elseif (cbc_dir == 2) then + else if (cbc_dir == 2) then is1%beg = 0; is1%end = buff_size; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) else @@ -1172,83 +1008,74 @@ contains end if dj = max(0, cbc_loc) - $:GPU_UPDATE(device='[is1,is2,is3,dj]') - $:GPU_UPDATE(device='[dir_idx,dir_flg]') + $:GPU_UPDATE(device='[is1, is2, is3, dj]') + $:GPU_UPDATE(device='[dir_idx, dir_flg]') ! Reshaping Inputted Data in x-direction if (cbc_dir == 1) then - - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, sys_size do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size - q_prim_rsx_vf(j, k, r, i) = & - q_prim_vf(i)%sf(dj*(m - 2*j) + j, k, r) + q_prim_rsx_vf(j, k, r, i) = q_prim_vf(i)%sf(dj*(m - 2*j) + j, k, r) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size - q_prim_rsx_vf(j, k, r, momxb) = & - q_prim_vf(momxb)%sf(dj*(m - 2*j) + j, k, r)* & - sign(1._wp, -1._wp*cbc_loc) + q_prim_rsx_vf(j, k, r, momxb) = q_prim_vf(momxb)%sf(dj*(m - 2*j) + j, k, r)*sign(1._wp, -1._wp*cbc_loc) end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_rsx_vf_l(j, k, r, i) = & - flux_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r)* & - sign(1._wp, -1._wp*cbc_loc) + flux_rsx_vf_l(j, k, r, i) = flux_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r)*sign(1._wp, -1._wp*cbc_loc) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_rsx_vf_l(j, k, r, momxb) = & - flux_vf(momxb)%sf(dj*((m - 1) - 2*j) + j, k, r) + flux_rsx_vf_l(j, k, r, momxb) = flux_vf(momxb)%sf(dj*((m - 1) - 2*j) + j, k, r) end do end do end do $:END_GPU_PARALLEL_LOOP() if (riemann_solver == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_rsx_vf_l(j, k, r, i) = & - flux_src_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r) + flux_src_rsx_vf_l(j, k, r, i) = flux_src_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_rsx_vf_l(j, k, r, advxb) = & - flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r)* & - sign(1._wp, -1._wp*cbc_loc) + flux_src_rsx_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r)*sign(1._wp, & + & -1._wp*cbc_loc) end do end do end do @@ -1258,79 +1085,71 @@ contains ! END: Reshaping Inputted Data in x-direction ! Reshaping Inputted Data in y-direction - elseif (cbc_dir == 2) then - - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + else if (cbc_dir == 2) then + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, sys_size do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size - q_prim_rsy_vf(j, k, r, i) = & - q_prim_vf(i)%sf(k, dj*(n - 2*j) + j, r) + q_prim_rsy_vf(j, k, r, i) = q_prim_vf(i)%sf(k, dj*(n - 2*j) + j, r) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size - q_prim_rsy_vf(j, k, r, momxb + 1) = & - q_prim_vf(momxb + 1)%sf(k, dj*(n - 2*j) + j, r)* & - sign(1._wp, -1._wp*cbc_loc) + q_prim_rsy_vf(j, k, r, momxb + 1) = q_prim_vf(momxb + 1)%sf(k, dj*(n - 2*j) + j, r)*sign(1._wp, & + & -1._wp*cbc_loc) end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_rsy_vf_l(j, k, r, i) = & - flux_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r)* & - sign(1._wp, -1._wp*cbc_loc) + flux_rsy_vf_l(j, k, r, i) = flux_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r)*sign(1._wp, -1._wp*cbc_loc) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_rsy_vf_l(j, k, r, momxb + 1) = & - flux_vf(momxb + 1)%sf(k, dj*((n - 1) - 2*j) + j, r) + flux_rsy_vf_l(j, k, r, momxb + 1) = flux_vf(momxb + 1)%sf(k, dj*((n - 1) - 2*j) + j, r) end do end do end do $:END_GPU_PARALLEL_LOOP() if (riemann_solver == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_rsy_vf_l(j, k, r, i) = & - flux_src_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r) + flux_src_rsy_vf_l(j, k, r, i) = flux_src_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_rsy_vf_l(j, k, r, advxb) = & - flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r)* & - sign(1._wp, -1._wp*cbc_loc) + flux_src_rsy_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r)*sign(1._wp, & + & -1._wp*cbc_loc) end do end do end do @@ -1342,102 +1161,86 @@ contains ! Reshaping Inputted Data in z-direction else - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, sys_size do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size - q_prim_rsz_vf(j, k, r, i) = & - q_prim_vf(i)%sf(r, k, dj*(p - 2*j) + j) + q_prim_rsz_vf(j, k, r, i) = q_prim_vf(i)%sf(r, k, dj*(p - 2*j) + j) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = 0, buff_size - q_prim_rsz_vf(j, k, r, momxe) = & - q_prim_vf(momxe)%sf(r, k, dj*(p - 2*j) + j)* & - sign(1._wp, -1._wp*cbc_loc) + q_prim_rsz_vf(j, k, r, momxe) = q_prim_vf(momxe)%sf(r, k, dj*(p - 2*j) + j)*sign(1._wp, -1._wp*cbc_loc) end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_rsz_vf_l(j, k, r, i) = & - flux_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j)* & - sign(1._wp, -1._wp*cbc_loc) + flux_rsz_vf_l(j, k, r, i) = flux_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j)*sign(1._wp, -1._wp*cbc_loc) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_rsz_vf_l(j, k, r, momxe) = & - flux_vf(momxe)%sf(r, k, dj*((p - 1) - 2*j) + j) + flux_rsz_vf_l(j, k, r, momxe) = flux_vf(momxe)%sf(r, k, dj*((p - 1) - 2*j) + j) end do end do end do $:END_GPU_PARALLEL_LOOP() if (riemann_solver == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_rsz_vf_l(j, k, r, i) = & - flux_src_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j) + flux_src_rsz_vf_l(j, k, r, i) = flux_src_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_rsz_vf_l(j, k, r, advxb) = & - flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j)* & - sign(1._wp, -1._wp*cbc_loc) + flux_src_rsz_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j)*sign(1._wp, & + & -1._wp*cbc_loc) end do end do end do $:END_GPU_PARALLEL_LOOP() end if - end if ! END: Reshaping Inputted Data in z-direction ! Association of the procedural pointer to the appropriate procedure ! that will be utilized in the evaluation of L variables for the CBC - end subroutine s_initialize_cbc - - !> Deallocation and/or the disassociation procedures that - !! are necessary in order to finalize the CBC application - !! @param flux_vf Cell-boundary-average fluxes - !! @param flux_src_vf Cell-boundary-average flux sources + !> Deallocation and/or the disassociation procedures that are necessary in order to finalize the CBC application + !! @param flux_vf Cell-boundary-average fluxes + !! @param flux_src_vf Cell-boundary-average flux sources subroutine s_finalize_cbc(flux_vf, flux_src_vf) - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf - - integer :: i, j, k, r !< Generic loop iterators + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf + integer :: i, j, k, r !< Generic loop iterators ! Determining the indicial shift based on CBC location dj = max(0, cbc_loc) @@ -1445,52 +1248,46 @@ contains ! Reshaping Outputted Data in x-direction if (cbc_dir == 1) then - - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r) = & - flux_rsx_vf_l(j, k, r, i)* & - sign(1._wp, -1._wp*cbc_loc) + flux_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r) = flux_rsx_vf_l(j, k, r, i)*sign(1._wp, -1._wp*cbc_loc) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_vf(momxb)%sf(dj*((m - 1) - 2*j) + j, k, r) = & - flux_rsx_vf_l(j, k, r, momxb) + flux_vf(momxb)%sf(dj*((m - 1) - 2*j) + j, k, r) = flux_rsx_vf_l(j, k, r, momxb) end do end do end do $:END_GPU_PARALLEL_LOOP() if (riemann_solver == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r) = & - flux_src_rsx_vf_l(j, k, r, i) + flux_src_vf(i)%sf(dj*((m - 1) - 2*j) + j, k, r) = flux_src_rsx_vf_l(j, k, r, i) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r) = & - flux_src_rsx_vf_l(j, k, r, advxb)* & - sign(1._wp, -1._wp*cbc_loc) + flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r) = flux_src_rsx_vf_l(j, k, r, advxb)*sign(1._wp, & + & -1._wp*cbc_loc) end do end do end do @@ -1499,54 +1296,48 @@ contains ! END: Reshaping Outputted Data in x-direction ! Reshaping Outputted Data in y-direction - elseif (cbc_dir == 2) then - - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + else if (cbc_dir == 2) then + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r) = & - flux_rsy_vf_l(j, k, r, i)* & - sign(1._wp, -1._wp*cbc_loc) + flux_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r) = flux_rsy_vf_l(j, k, r, i)*sign(1._wp, -1._wp*cbc_loc) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_vf(momxb + 1)%sf(k, dj*((n - 1) - 2*j) + j, r) = & - flux_rsy_vf_l(j, k, r, momxb + 1) + flux_vf(momxb + 1)%sf(k, dj*((n - 1) - 2*j) + j, r) = flux_rsy_vf_l(j, k, r, momxb + 1) end do end do end do $:END_GPU_PARALLEL_LOOP() if (riemann_solver == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r) = & - flux_src_rsy_vf_l(j, k, r, i) + flux_src_vf(i)%sf(k, dj*((n - 1) - 2*j) + j, r) = flux_src_rsy_vf_l(j, k, r, i) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r) = & - flux_src_rsy_vf_l(j, k, r, advxb)* & - sign(1._wp, -1._wp*cbc_loc) + flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r) = flux_src_rsy_vf_l(j, k, r, advxb)*sign(1._wp, & + & -1._wp*cbc_loc) end do end do end do @@ -1558,66 +1349,57 @@ contains ! Reshaping Outputted Data in z-direction else - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j) = & - flux_rsz_vf_l(j, k, r, i)* & - sign(1._wp, -1._wp*cbc_loc) + flux_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j) = flux_rsz_vf_l(j, k, r, i)*sign(1._wp, -1._wp*cbc_loc) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_vf(momxe)%sf(r, k, dj*((p - 1) - 2*j) + j) = & - flux_rsz_vf_l(j, k, r, momxe) + flux_vf(momxe)%sf(r, k, dj*((p - 1) - 2*j) + j) = flux_rsz_vf_l(j, k, r, momxe) end do end do end do $:END_GPU_PARALLEL_LOOP() if (riemann_solver == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = advxb, advxe do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j) = & - flux_src_rsz_vf_l(j, k, r, i) + flux_src_vf(i)%sf(r, k, dj*((p - 1) - 2*j) + j) = flux_src_rsz_vf_l(j, k, r, i) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,r]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, r]', collapse=3) do r = is3%beg, is3%end do k = is2%beg, is2%end do j = -1, buff_size - flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j) = & - flux_src_rsz_vf_l(j, k, r, advxb)* & - sign(1._wp, -1._wp*cbc_loc) + flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j) = flux_src_rsz_vf_l(j, k, r, advxb)*sign(1._wp, & + & -1._wp*cbc_loc) end do end do end do $:END_GPU_PARALLEL_LOOP() end if - end if ! END: Reshaping Outputted Data in z-direction - end subroutine s_finalize_cbc - !> @brief Detects whether any domain boundary uses characteristic boundary conditions. elemental subroutine s_any_cbc_boundaries(toggle) - logical, intent(inout) :: toggle toggle = .false. @@ -1627,12 +1409,9 @@ contains toggle = .true. end if #:endfor - end subroutine s_any_cbc_boundaries - !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_cbc_module - logical :: is_cbc call s_any_cbc_boundaries(is_cbc) @@ -1668,9 +1447,8 @@ contains @:DEALLOCATE(vel_in, vel_out, pres_in, pres_out, Del_in, Del_out, alpha_rho_in, alpha_in) ! Deallocating CBC Coefficients in x-direction - if (all((/bc_x%beg, bc_x%end/) <= -5) .and. all((/bc_x%beg, bc_x%end/) >= -13) .or. & - bc_x%beg <= -5 .and. bc_x%beg >= -13 .or. & - bc_x%end <= -5 .and. bc_x%end >= -13) then + if (all((/bc_x%beg, bc_x%end/) <= -5) .and. all((/bc_x%beg, & + & bc_x%end/) >= -13) .or. bc_x%beg <= -5 .and. bc_x%beg >= -13 .or. bc_x%end <= -5 .and. bc_x%end >= -13) then @:DEALLOCATE(fd_coef_x) if (weno_order > 1 .or. muscl_order > 1) then @:DEALLOCATE(pi_coef_x) @@ -1679,9 +1457,8 @@ contains ! Deallocating CBC Coefficients in y-direction if (n > 0) then - if (all((/bc_y%beg, bc_y%end/) <= -5) .and. all((/bc_y%beg, bc_y%end/) >= -13) .or. & - bc_y%beg <= -5 .and. bc_y%beg >= -13 .or. & - bc_y%end <= -5 .and. bc_y%end >= -13) then + if (all((/bc_y%beg, bc_y%end/) <= -5) .and. all((/bc_y%beg, & + & bc_y%end/) >= -13) .or. bc_y%beg <= -5 .and. bc_y%beg >= -13 .or. bc_y%end <= -5 .and. bc_y%end >= -13) then @:DEALLOCATE(fd_coef_y) if (weno_order > 1) then @:DEALLOCATE(pi_coef_y) @@ -1691,16 +1468,13 @@ contains ! Deallocating CBC Coefficients in z-direction if (p > 0) then - if (all((/bc_z%beg, bc_z%end/) <= -5) .and. all((/bc_z%beg, bc_z%end/) >= -13) .or. & - bc_z%beg <= -5 .and. bc_z%beg >= -13 .or. & - bc_z%end <= -5 .and. bc_z%end >= -13) then + if (all((/bc_z%beg, bc_z%end/) <= -5) .and. all((/bc_z%beg, & + & bc_z%end/) >= -13) .or. bc_z%beg <= -5 .and. bc_z%beg >= -13 .or. bc_z%end <= -5 .and. bc_z%end >= -13) then @:DEALLOCATE(fd_coef_z) if (weno_order > 1) then @:DEALLOCATE(pi_coef_z) end if end if end if - end subroutine s_finalize_cbc_module - end module m_cbc diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 5543cba645..7b3f6fb964 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -7,7 +7,6 @@ !> @brief Validates simulation input parameters for consistency and supported configurations module m_checker - use m_global_parameters !< Definitions of the global parameters use m_mpi_proxy !< Message passing interface (MPI) module proxy @@ -19,13 +18,10 @@ module m_checker implicit none private; public :: s_check_inputs - contains - !> Checks compatibility of parameters in the input file. - !! Used by the simulation stage + !> Checks compatibility of parameters in the input file. Used by the simulation stage impure subroutine s_check_inputs - call s_check_inputs_compilers if (igr) then @@ -41,56 +37,41 @@ contains call s_check_inputs_time_stepping @:PROHIBIT(ib_state_wrt .and. .not. ib, "ib_state_wrt requires ib to be enabled") - end subroutine s_check_inputs - !> Checks constraints on compiler options impure subroutine s_check_inputs_compilers #if !defined(MFC_OpenACC) && !(defined(__PGI) || defined(_CRAYFTN)) @:PROHIBIT(rdma_mpi, "Unsupported value of rdma_mpi for the current compiler") #endif end subroutine s_check_inputs_compilers - !> Checks constraints on WENO scheme parameters impure subroutine s_check_inputs_weno character(len=5) :: numStr !< for int to string conversion call s_int_to_str(num_stcls_min*weno_order, numStr) - @:PROHIBIT(m + 1 < num_stcls_min*weno_order, & - "m must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) - @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*weno_order, & - "For 2D simulation, n must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) - @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*weno_order, & - "For 3D simulation, p must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) + @:PROHIBIT(m + 1 < num_stcls_min*weno_order, "m must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) + @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*weno_order, "For 2D simulation, n must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) + @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*weno_order, "For 3D simulation, p must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) end subroutine s_check_inputs_weno - !> @brief Validates that the grid resolution is sufficient for the MUSCL reconstruction order. impure subroutine s_check_inputs_muscl character(len=5) :: numStr !< for int to string conversion call s_int_to_str(num_stcls_min*muscl_order, numStr) - @:PROHIBIT(m + 1 < num_stcls_min*muscl_order, & - "m must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) - @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*muscl_order, & - "For 2D simulation, n must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) - @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*muscl_order, & - "For 3D simulation, p must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) + @:PROHIBIT(m + 1 < num_stcls_min*muscl_order, "m must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) + @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*muscl_order, "For 2D simulation, n must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) + @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*muscl_order, "For 3D simulation, p must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) end subroutine s_check_inputs_muscl - !> Checks constraints on time stepping parameters impure subroutine s_check_inputs_time_stepping if (.not. cfl_dt) then @:PROHIBIT(dt <= 0) end if end subroutine s_check_inputs_time_stepping - impure subroutine s_check_inputs_nvidia_uvm #ifdef __NVCOMPILER_GPU_UNIFIED_MEM - @:PROHIBIT(nv_uvm_igr_temps_on_gpu > 3 .or. nv_uvm_igr_temps_on_gpu < 0, & - "nv_uvm_igr_temps_on_gpu must be in the range [0, 3]") - @:PROHIBIT(nv_uvm_igr_temps_on_gpu == 3 .and. igr_iter_solver == 2, & - "nv_uvm_igr_temps_on_gpu must be in the range [0, 2] for igr_iter_solver == 2") + @:PROHIBIT(nv_uvm_igr_temps_on_gpu > 3 .or. nv_uvm_igr_temps_on_gpu < 0, "nv_uvm_igr_temps_on_gpu must be in the range [0, 3]") + @:PROHIBIT(nv_uvm_igr_temps_on_gpu == 3 .and. igr_iter_solver == 2, "nv_uvm_igr_temps_on_gpu must be in the range [0, 2] for igr_iter_solver == 2") #endif end subroutine s_check_inputs_nvidia_uvm - end module m_checker diff --git a/src/simulation/m_compute_cbc.fpp b/src/simulation/m_compute_cbc.fpp index bb7c59ac5f..5931a78d7d 100644 --- a/src/simulation/m_compute_cbc.fpp +++ b/src/simulation/m_compute_cbc.fpp @@ -9,21 +9,16 @@ module m_compute_cbc use m_global_parameters implicit none - private; public :: s_compute_slip_wall_L, & - s_compute_nonreflecting_subsonic_buffer_L, & - s_compute_nonreflecting_subsonic_inflow_L, & - s_compute_nonreflecting_subsonic_outflow_L, & - s_compute_force_free_subsonic_outflow_L, & - s_compute_constant_pressure_subsonic_outflow_L, & - s_compute_supersonic_inflow_L, & - s_compute_supersonic_outflow_L - + private; public :: s_compute_slip_wall_L, s_compute_nonreflecting_subsonic_buffer_L, & + & s_compute_nonreflecting_subsonic_inflow_L, s_compute_nonreflecting_subsonic_outflow_L, & + & s_compute_force_free_subsonic_outflow_L, s_compute_constant_pressure_subsonic_outflow_L, s_compute_supersonic_inflow_L, & + & s_compute_supersonic_outflow_L contains !> Base L1 calculation function f_base_L1(lambda, rho, c, dpres_ds, dvel_ds) result(L1) $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(3), intent(in) :: lambda - real(wp), intent(in) :: rho, c, dpres_ds + real(wp), intent(in) :: rho, c, dpres_ds #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3), intent(in) :: dvel_ds #:else @@ -32,7 +27,6 @@ contains real(wp) :: L1 L1 = lambda(1)*(dpres_ds - rho*c*dvel_ds(dir_idx(1))) end function f_base_L1 - !> Fill density L variables subroutine s_fill_density_L(L, lambda_factor, lambda2, c, mf, dalpha_rho_ds, dpres_ds) $:GPU_ROUTINE(parallelism='[seq]') @@ -48,14 +42,13 @@ contains #:endif real(wp), intent(in) :: lambda_factor, lambda2, c real(wp), intent(in) :: dpres_ds - integer :: i + integer :: i ! $:GPU_LOOP(parallelism='[seq]') do i = 2, momxb L(i) = lambda_factor*lambda2*(c*c*dalpha_rho_ds(i - 1) - mf(i - 1)*dpres_ds) end do end subroutine s_fill_density_L - !> Fill velocity L variables subroutine s_fill_velocity_L(L, lambda_factor, lambda2, dvel_ds) $:GPU_ROUTINE(parallelism='[seq]') @@ -70,14 +63,13 @@ contains real(wp), dimension(num_dims), intent(in) :: dvel_ds #:endif real(wp), intent(in) :: lambda_factor, lambda2 - integer :: i + integer :: i ! $:GPU_LOOP(parallelism='[seq]') do i = momxb + 1, momxe L(i) = lambda_factor*lambda2*dvel_ds(dir_idx(i - contxe)) end do end subroutine s_fill_velocity_L - !> Fill advection L variables subroutine s_fill_advection_L(L, lambda_factor, lambda2, dadv_ds) $:GPU_ROUTINE(parallelism='[seq]') @@ -92,14 +84,13 @@ contains real(wp), dimension(num_fluids), intent(in) :: dadv_ds #:endif real(wp), intent(in) :: lambda_factor, lambda2 - integer :: i + integer :: i ! $:GPU_LOOP(parallelism='[seq]') do i = E_idx, advxe - 1 L(i) = lambda_factor*lambda2*dadv_ds(i - momxe) end do end subroutine s_fill_advection_L - !> Fill chemistry L variables subroutine s_fill_chemistry_L(L, lambda_factor, lambda2, dYs_ds) $:GPU_ROUTINE(parallelism='[seq]') @@ -114,7 +105,7 @@ contains real(wp), dimension(num_species), intent(in) :: dYs_ds #:endif real(wp), intent(in) :: lambda_factor, lambda2 - integer :: i + integer :: i if (.not. chemistry) return @@ -123,11 +114,9 @@ contains L(i) = lambda_factor*lambda2*dYs_ds(i - chemxb + 1) end do end subroutine s_fill_chemistry_L - !> Slip wall CBC (Thompson 1990, pg. 451) subroutine s_compute_slip_wall_L(lambda, L, rho, c, dpres_ds, dvel_ds) - $:GPU_ROUTINE(function_name='s_compute_slip_wall_L',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_slip_wall_L',parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda #:if USING_AMD @@ -141,17 +130,15 @@ contains real(wp), dimension(num_dims), intent(in) :: dvel_ds #:endif real(wp), intent(in) :: rho, c, dpres_ds - integer :: i + integer :: i L(1) = f_base_L1(lambda, rho, c, dpres_ds, dvel_ds) L(2:advxe - 1) = 0._wp L(advxe) = L(1) end subroutine s_compute_slip_wall_L - !> Nonreflecting subsonic buffer CBC (Thompson 1987, pg. 13) subroutine s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) - $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_buffer_L', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_buffer_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda #:if USING_AMD @@ -160,20 +147,19 @@ contains real(wp), dimension(sys_size), intent(inout) :: L #:endif #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3), intent(in) :: mf, dalpha_rho_ds - real(wp), dimension(3), intent(in) :: dvel_ds - real(wp), dimension(3), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: mf, dalpha_rho_ds + real(wp), dimension(3), intent(in) :: dvel_ds + real(wp), dimension(3), intent(in) :: dadv_ds real(wp), dimension(10), intent(in) :: dYs_ds #:else - real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(wp), dimension(num_dims), intent(in) :: dvel_ds - real(wp), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds real(wp), dimension(num_species), intent(in) :: dYs_ds #:endif real(wp), intent(in) :: rho, c real(wp), intent(in) :: dpres_ds - - real(wp) :: lambda_factor + real(wp) :: lambda_factor lambda_factor = (5.e-1_wp - 5.e-1_wp*sign(1._wp, lambda(1))) L(1) = lambda_factor*lambda(1)*(dpres_ds - rho*c*dvel_ds(dir_idx(1))) @@ -187,11 +173,9 @@ contains lambda_factor = (5.e-1_wp - 5.e-1_wp*sign(1._wp, lambda(3))) L(advxe) = lambda_factor*lambda(3)*(dpres_ds + rho*c*dvel_ds(dir_idx(1))) end subroutine s_compute_nonreflecting_subsonic_buffer_L - !> Nonreflecting subsonic inflow CBC (Thompson 1990, pg. 455) subroutine s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, dpres_ds, dvel_ds) - $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_inflow_L', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_inflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda #:if USING_AMD @@ -210,11 +194,9 @@ contains L(2:advxe) = 0._wp if (chemistry) L(chemxb:chemxe) = 0._wp end subroutine s_compute_nonreflecting_subsonic_inflow_L - !> Nonreflecting subsonic outflow CBC (Thompson 1990, pg. 454) subroutine s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) - $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_outflow_L', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda #:if USING_AMD @@ -223,14 +205,14 @@ contains real(wp), dimension(sys_size), intent(inout) :: L #:endif #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3), intent(in) :: mf, dalpha_rho_ds - real(wp), dimension(3), intent(in) :: dvel_ds - real(wp), dimension(3), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: mf, dalpha_rho_ds + real(wp), dimension(3), intent(in) :: dvel_ds + real(wp), dimension(3), intent(in) :: dadv_ds real(wp), dimension(10), intent(in) :: dYs_ds #:else - real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(wp), dimension(num_dims), intent(in) :: dvel_ds - real(wp), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds real(wp), dimension(num_species), intent(in) :: dYs_ds #:endif real(wp), intent(in) :: rho, c @@ -243,11 +225,9 @@ contains call s_fill_chemistry_L(L, 1._wp, lambda(2), dYs_ds) L(advxe) = 0._wp end subroutine s_compute_nonreflecting_subsonic_outflow_L - !> Force-free subsonic outflow CBC (Thompson 1990, pg. 454) subroutine s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) - $:GPU_ROUTINE(function_name='s_compute_force_free_subsonic_outflow_L', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_force_free_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda #:if USING_AMD @@ -261,7 +241,7 @@ contains real(wp), dimension(3), intent(in) :: dadv_ds #:else real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds real(wp), dimension(num_fluids), intent(in) :: dadv_ds #:endif real(wp), intent(in) :: rho, c @@ -273,11 +253,9 @@ contains call s_fill_advection_L(L, 1._wp, lambda(2), dadv_ds) L(advxe) = L(1) + 2._wp*rho*c*lambda(2)*dvel_ds(dir_idx(1)) end subroutine s_compute_force_free_subsonic_outflow_L - !> Constant pressure subsonic outflow CBC (Thompson 1990, pg. 455) subroutine s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) - $:GPU_ROUTINE(function_name='s_compute_constant_pressure_subsonic_outflow_L', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_constant_pressure_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda #:if USING_AMD @@ -291,7 +269,7 @@ contains real(wp), dimension(3), intent(in) :: dadv_ds #:else real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds real(wp), dimension(num_fluids), intent(in) :: dadv_ds #:endif real(wp), intent(in) :: rho, c @@ -303,11 +281,9 @@ contains call s_fill_advection_L(L, 1._wp, lambda(2), dadv_ds) L(advxe) = -L(1) end subroutine s_compute_constant_pressure_subsonic_outflow_L - !> Supersonic inflow CBC (Thompson 1990, pg. 453) subroutine s_compute_supersonic_inflow_L(L) - $:GPU_ROUTINE(function_name='s_compute_supersonic_inflow_L', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_supersonic_inflow_L', parallelism='[seq]', cray_inline=True) #:if USING_AMD real(wp), dimension(20), intent(inout) :: L #:else @@ -316,11 +292,9 @@ contains L(1:advxe) = 0._wp if (chemistry) L(chemxb:chemxe) = 0._wp end subroutine s_compute_supersonic_inflow_L - !> Supersonic outflow CBC (Thompson 1990, pg. 453) subroutine s_compute_supersonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) - $:GPU_ROUTINE(function_name='s_compute_supersonic_outflow_L', & - & parallelism='[seq]', cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_supersonic_outflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda #:if USING_AMD @@ -329,14 +303,14 @@ contains real(wp), dimension(sys_size), intent(inout) :: L #:endif #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3), intent(in) :: mf, dalpha_rho_ds - real(wp), dimension(3), intent(in) :: dvel_ds - real(wp), dimension(3), intent(in) :: dadv_ds + real(wp), dimension(3), intent(in) :: mf, dalpha_rho_ds + real(wp), dimension(3), intent(in) :: dvel_ds + real(wp), dimension(3), intent(in) :: dadv_ds real(wp), dimension(10), intent(in) :: dYs_ds #:else - real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds - real(wp), dimension(num_dims), intent(in) :: dvel_ds - real(wp), dimension(num_fluids), intent(in) :: dadv_ds + real(wp), dimension(num_fluids), intent(in) :: mf, dalpha_rho_ds + real(wp), dimension(num_dims), intent(in) :: dvel_ds + real(wp), dimension(num_fluids), intent(in) :: dadv_ds real(wp), dimension(num_species), intent(in) :: dYs_ds #:endif real(wp), intent(in) :: rho, c diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index 0663ae73ca..8484659b2b 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -6,7 +6,6 @@ !> @brief Computes signed-distance level-set fields and surface normals for immersed-boundary patch geometries module m_compute_levelset - use m_ib_patches !< The IB patch parameters use m_model !< Subroutine(s) related to STL files @@ -22,79 +21,66 @@ module m_compute_levelset implicit none private; public :: s_apply_levelset - contains !> @brief Dispatches level-set distance and normal computations for all ghost points based on their patch geometry type. impure subroutine s_apply_levelset(gps, num_gps) - type(ghost_point), dimension(:), intent(inout) :: gps - integer, intent(in) :: num_gps - - integer :: i, patch_id, patch_geometry + integer, intent(in) :: num_gps + integer :: i, patch_id, patch_geometry ! 3D Patch Geometries if (p > 0) then - - $:GPU_PARALLEL_LOOP(private='[i,patch_id,patch_geometry]', copy='[gps]', copyin='[patch_ib(1:num_ibs),Np]') + $:GPU_PARALLEL_LOOP(private='[i, patch_id, patch_geometry]', copy='[gps]', copyin='[patch_ib(1:num_ibs), Np]') do i = 1, num_gps - patch_id = gps(i)%ib_patch_id patch_geometry = patch_ib(patch_id)%geometry if (patch_geometry == 8) then call s_sphere_levelset(gps(i)) - elseif (patch_geometry == 9) then + else if (patch_geometry == 9) then call s_cuboid_levelset(gps(i)) - elseif (patch_geometry == 10) then + else if (patch_geometry == 10) then call s_cylinder_levelset(gps(i)) - elseif (patch_geometry == 11) then + else if (patch_geometry == 11) then call s_3d_airfoil_levelset(gps(i)) - elseif (patch_geometry == 12) then + else if (patch_geometry == 12) then call s_model_levelset(gps(i)) end if end do $:END_GPU_PARALLEL_LOOP() ! 2D Patch Geometries - elseif (n > 0) then - - $:GPU_PARALLEL_LOOP(private='[i,patch_id,patch_geometry]', copy='[gps]', copyin='[Np,patch_ib(1:num_ibs)]') + else if (n > 0) then + $:GPU_PARALLEL_LOOP(private='[i, patch_id, patch_geometry]', copy='[gps]', copyin='[Np, patch_ib(1:num_ibs)]') do i = 1, num_gps - patch_id = gps(i)%ib_patch_id patch_geometry = patch_ib(patch_id)%geometry if (patch_geometry == 2) then call s_circle_levelset(gps(i)) - elseif (patch_geometry == 3) then + else if (patch_geometry == 3) then call s_rectangle_levelset(gps(i)) - elseif (patch_geometry == 4) then + else if (patch_geometry == 4) then call s_airfoil_levelset(gps(i)) - elseif (patch_geometry == 5) then + else if (patch_geometry == 5) then call s_model_levelset(gps(i)) - elseif (patch_geometry == 6) then + else if (patch_geometry == 6) then call s_ellipse_levelset(gps(i)) end if end do $:END_GPU_PARALLEL_LOOP() - end if - end subroutine s_apply_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to a circular immersed boundary. subroutine s_circle_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - real(wp) :: radius, dist - real(wp), dimension(2) :: center - real(wp), dimension(3) :: dist_vec - - integer :: i, j, ib_patch_id !< Loop index variables + real(wp) :: radius, dist + real(wp), dimension(2) :: center + real(wp), dimension(3) :: dist_vec + integer :: i, j, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -113,25 +99,19 @@ contains else gp%levelset_norm = dist_vec(:)/dist end if - end subroutine s_circle_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to a 2D NACA airfoil surface. subroutine s_airfoil_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - real(wp) :: dist, global_dist - integer :: global_id - real(wp), dimension(3) :: dist_vec - - real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: center - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - - integer :: i, j, k, ib_patch_id !< Loop index variables + real(wp) :: dist, global_dist + integer :: global_id + real(wp), dimension(3) :: dist_vec + real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: center + real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + integer :: i, j, k, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -139,8 +119,8 @@ contains center(1) = patch_ib(ib_patch_id)%x_centroid + real(gp%x_periodicity, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(ib_patch_id)%y_centroid + real(gp%y_periodicity, wp)*(y_domain%end - y_domain%beg) - inverse_rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:, :) - rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix(:, :) + inverse_rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:,:) + rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix(:,:) offset(:) = patch_ib(ib_patch_id)%centroid_offset(:) xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] ! get coordinate frame centered on IB @@ -196,27 +176,21 @@ contains else gp%levelset_norm = matmul(rotation, dist_vec(:))/dist ! convert the normal vector back to global grid coordinates end if - end subroutine s_airfoil_levelset - - !> @brief Computes the signed distance and outward normal from a ghost point to a 3D extruded airfoil surface including spanwise end caps. + !> @brief Computes the signed distance and outward normal from a ghost point to a 3D extruded airfoil surface including spanwise + !! end caps. subroutine s_3d_airfoil_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - real(wp) :: dist, dist_surf, dist_side, global_dist - integer :: global_id - real(wp) :: lz, z_max, z_min - real(wp), dimension(3) :: dist_vec - - real(wp), dimension(1:3) :: xyz_local, center, offset, normal !< x, y, z coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - - real(wp) :: length_z - - integer :: i, j, k, l, ib_patch_id !< Loop index variables + real(wp) :: dist, dist_surf, dist_side, global_dist + integer :: global_id + real(wp) :: lz, z_max, z_min + real(wp), dimension(3) :: dist_vec + real(wp), dimension(1:3) :: xyz_local, center, offset, normal !< x, y, z coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + real(wp) :: length_z + integer :: i, j, k, l, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -227,8 +201,8 @@ contains center(2) = patch_ib(ib_patch_id)%y_centroid + real(gp%y_periodicity, wp)*(y_domain%end - y_domain%beg) center(3) = patch_ib(ib_patch_id)%z_centroid + real(gp%z_periodicity, wp)*(z_domain%end - z_domain%beg) lz = patch_ib(ib_patch_id)%length_z - inverse_rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:, :) - rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix(:, :) + inverse_rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:,:) + rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix(:,:) offset(:) = patch_ib(ib_patch_id)%centroid_offset(:) z_max = lz/2 @@ -299,28 +273,22 @@ contains gp%levelset_norm = matmul(rotation, dist_vec(:)/dist_surf) end if end if - end subroutine s_3d_airfoil_levelset - - !> Subroutine for computing the levelset values at a ghost point belonging to the rectangle IB + !> Subroutine for computing the levelset values at a ghost point belonging to the rectangle IB subroutine s_rectangle_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - real(wp) :: top_right(2), bottom_left(2) - real(wp) :: min_dist - real(wp) :: side_dists(4) - - real(wp) :: length_x, length_y - real(wp), dimension(1:3) :: xy_local, dist_vec !< x and y coordinates in local IB frame - real(wp), dimension(2) :: center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - - integer :: i, j, k !< Loop index variables - integer :: idx !< Shortest path direction indicator - integer :: ib_patch_id !< patch ID + real(wp) :: top_right(2), bottom_left(2) + real(wp) :: min_dist + real(wp) :: side_dists(4) + real(wp) :: length_x, length_y + real(wp), dimension(1:3) :: xy_local, dist_vec !< x and y coordinates in local IB frame + real(wp), dimension(2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + integer :: i, j, k !< Loop index variables + integer :: idx !< Shortest path direction indicator + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -330,8 +298,8 @@ contains length_y = patch_ib(ib_patch_id)%length_y center(1) = patch_ib(ib_patch_id)%x_centroid + real(gp%x_periodicity, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(ib_patch_id)%y_centroid + real(gp%y_periodicity, wp)*(y_domain%end - y_domain%beg) - inverse_rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:, :) - rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix(:, :) + inverse_rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:,:) + rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix(:,:) top_right(1) = length_x/2 top_right(2) = length_y/2 @@ -371,27 +339,22 @@ contains else gp%levelset_norm = 0._wp end if - end subroutine s_rectangle_levelset - - !> @brief Computes the signed distance and outward normal from a ghost point to an elliptical immersed boundary via a quadratic projection. + !> @brief Computes the signed distance and outward normal from a ghost point to an elliptical immersed boundary via a quadratic + !! projection. subroutine s_ellipse_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - real(wp) :: ellipse_coeffs(2) ! a and b in the ellipse equation - real(wp) :: quadratic_coeffs(3) ! A, B, C in the quadratic equation to compute levelset - - real(wp) :: length_x, length_y - real(wp), dimension(1:3) :: xy_local, normal_vector !< x and y coordinates in local IB frame - real(wp), dimension(2) :: center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - - integer :: i, j, k !< Loop index variables - integer :: idx !< Shortest path direction indicator - integer :: ib_patch_id !< patch ID + real(wp) :: ellipse_coeffs(2) ! a and b in the ellipse equation + real(wp) :: quadratic_coeffs(3) ! A, B, C in the quadratic equation to compute levelset + real(wp) :: length_x, length_y + real(wp), dimension(1:3) :: xy_local, normal_vector !< x and y coordinates in local IB frame + real(wp), dimension(2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + integer :: i, j, k !< Loop index variables + integer :: idx !< Shortest path direction indicator + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -401,8 +364,8 @@ contains length_y = patch_ib(ib_patch_id)%length_y center(1) = patch_ib(ib_patch_id)%x_centroid + real(gp%x_periodicity, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(ib_patch_id)%y_centroid + real(gp%y_periodicity, wp)*(y_domain%end - y_domain%beg) - inverse_rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:, :) - rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix(:, :) + inverse_rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:,:) + rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix(:,:) ellipse_coeffs(1) = 0.5_wp*length_x ellipse_coeffs(2) = 0.5_wp*length_y @@ -411,38 +374,35 @@ contains xy_local = matmul(inverse_rotation, xy_local) normal_vector = xy_local - normal_vector(2) = normal_vector(2)*(ellipse_coeffs(1)/ellipse_coeffs(2))**2._wp ! get the normal direction via the coordinate transformation method + normal_vector(2) = normal_vector(2)*(ellipse_coeffs(1)/ellipse_coeffs(2)) & + & **2._wp ! get the normal direction via the coordinate transformation method normal_vector = normal_vector/sqrt(dot_product(normal_vector, normal_vector)) ! normalize the vector gp%levelset_norm = matmul(rotation, normal_vector) ! save after rotating the vector to the global frame ! use the normal vector to set up the quadratic equation for the levelset, using A, B, and C in indices 1, 2, and 3 quadratic_coeffs(1) = (normal_vector(1)/ellipse_coeffs(1))**2 + (normal_vector(2)/ellipse_coeffs(2))**2 - quadratic_coeffs(2) = 2._wp*((xy_local(1)*normal_vector(1)/(ellipse_coeffs(1)**2)) + (xy_local(2)*normal_vector(2)/(ellipse_coeffs(2)**2))) + quadratic_coeffs(2) = 2._wp*((xy_local(1)*normal_vector(1)/(ellipse_coeffs(1)**2)) + (xy_local(2)*normal_vector(2) & + & /(ellipse_coeffs(2)**2))) quadratic_coeffs(3) = (xy_local(1)/ellipse_coeffs(1))**2._wp + (xy_local(2)/ellipse_coeffs(2))**2._wp - 1._wp ! compute the levelset with the quadratic equation [ -B + sqrt(B^2 - 4AC) ] / 2A - gp%levelset = -0.5_wp*(-quadratic_coeffs(2) + sqrt(quadratic_coeffs(2)**2._wp - 4._wp*quadratic_coeffs(1)*quadratic_coeffs(3)))/quadratic_coeffs(1) - + gp%levelset = -0.5_wp*(-quadratic_coeffs(2) + sqrt(quadratic_coeffs(2)**2._wp - 4._wp*quadratic_coeffs(1) & + & *quadratic_coeffs(3)))/quadratic_coeffs(1) end subroutine s_ellipse_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to the nearest face of a cuboid immersed boundary. subroutine s_cuboid_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - real(wp) :: Right, Left, Bottom, Top, Front, Back - real(wp) :: min_dist - real(wp) :: dist_left, dist_right, dist_bottom, dist_top, dist_back, dist_front - - real(wp), dimension(3) :: center - real(wp) :: length_x, length_y, length_z - real(wp), dimension(1:3) :: xyz_local, dist_vec !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - - integer :: i, j, k !< Loop index variables - integer :: ib_patch_id !< patch ID + real(wp) :: Right, Left, Bottom, Top, Front, Back + real(wp) :: min_dist + real(wp) :: dist_left, dist_right, dist_bottom, dist_top, dist_back, dist_front + real(wp), dimension(3) :: center + real(wp) :: length_x, length_y, length_z + real(wp), dimension(1:3) :: xyz_local, dist_vec !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + integer :: i, j, k !< Loop index variables + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -457,8 +417,8 @@ contains center(2) = patch_ib(ib_patch_id)%y_centroid + real(gp%y_periodicity, wp)*(y_domain%end - y_domain%beg) center(3) = patch_ib(ib_patch_id)%z_centroid + real(gp%z_periodicity, wp)*(z_domain%end - z_domain%beg) - inverse_rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:, :) - rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix(:, :) + inverse_rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:,:) + rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix(:,:) Right = length_x/2 Left = -length_x/2 @@ -477,8 +437,7 @@ contains dist_back = Back - xyz_local(3) dist_front = xyz_local(3) - Front - min_dist = min(abs(dist_left), abs(dist_right), abs(dist_bottom), & - abs(dist_top), abs(dist_back), abs(dist_front)) + min_dist = min(abs(dist_left), abs(dist_right), abs(dist_bottom), abs(dist_top), abs(dist_back), abs(dist_front)) dist_vec = 0._wp if (f_approx_equal(min_dist, abs(dist_left))) then @@ -514,20 +473,15 @@ contains end if gp%levelset_norm = matmul(rotation, dist_vec) - end subroutine s_cuboid_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to a spherical immersed boundary. subroutine s_sphere_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - real(wp) :: radius, dist - real(wp), dimension(3) :: dist_vec, center, periodicity - - integer :: i, j, k, ib_patch_id !< Loop index variables + real(wp) :: radius, dist + real(wp), dimension(3) :: dist_vec, center, periodicity + integer :: i, j, k, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -553,25 +507,21 @@ contains else gp%levelset_norm = dist_vec(:)/dist end if - end subroutine s_sphere_levelset - - !> @brief Computes the signed distance and outward normal from a ghost point to a cylindrical immersed boundary surface and end caps. + !> @brief Computes the signed distance and outward normal from a ghost point to a cylindrical immersed boundary surface and end + !! caps. subroutine s_cylinder_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - real(wp) :: radius - real(wp), dimension(3) :: dist_sides_vec, dist_surface_vec, length - real(wp), dimension(2) :: boundary - real(wp) :: dist_side, dist_surface, side_pos - integer :: i, j, k !< Loop index variables - integer :: ib_patch_id !< patch ID - - real(wp), dimension(1:3) :: xyz_local, center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + real(wp) :: radius + real(wp), dimension(3) :: dist_sides_vec, dist_surface_vec, length + real(wp), dimension(2) :: boundary + real(wp) :: dist_side, dist_surface, side_pos + integer :: i, j, k !< Loop index variables + integer :: ib_patch_id !< patch ID + real(wp), dimension(1:3) :: xyz_local, center !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -586,8 +536,8 @@ contains length(2) = patch_ib(ib_patch_id)%length_y length(3) = patch_ib(ib_patch_id)%length_z - inverse_rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:, :) - rotation(:, :) = patch_ib(ib_patch_id)%rotation_matrix(:, :) + inverse_rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix_inverse(:,:) + rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix(:,:) if (.not. f_approx_equal(length(1), 0._wp)) then boundary(1) = -0.5_wp*length(1) @@ -611,11 +561,9 @@ contains ! get distance to flat edge of cylinder side_pos = dot_product(xyz_local, dist_sides_vec) - dist_side = min(abs(side_pos - boundary(1)), & - abs(boundary(2) - side_pos)) + dist_side = min(abs(side_pos - boundary(1)), abs(boundary(2) - side_pos)) ! get distance to curved side of cylinder - dist_surface = norm2(xyz_local*dist_surface_vec) & - - radius + dist_surface = norm2(xyz_local*dist_surface_vec) - radius if (dist_side < abs(dist_surface)) then ! if the closest edge is flat @@ -631,22 +579,18 @@ contains xyz_local = xyz_local/max(norm2(xyz_local), sgm_eps) gp%levelset_norm = matmul(rotation, xyz_local) end if - end subroutine s_cylinder_levelset - !> The STL patch is a 2/3D geometry that is imported from an STL file. !! @param gp Ghost point to compute levelset for subroutine s_model_levelset(gp) - $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - - integer :: i, j, k, patch_id, boundary_edge_count, total_vertices - real(wp), dimension(1:3) :: center, xyz_local - real(wp) :: normals(1:3) !< Boundary normal buffer - real(wp) :: distance - real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation + integer :: i, j, k, patch_id, boundary_edge_count, total_vertices + real(wp), dimension(1:3) :: center, xyz_local + real(wp) :: normals(1:3) !< Boundary normal buffer + real(wp) :: distance + real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation patch_id = gp%ib_patch_id i = gp%loc(1) @@ -658,14 +602,17 @@ contains total_vertices = gpu_total_vertices(patch_id) center = 0._wp - if (.not. f_is_default(patch_ib(patch_id)%x_centroid)) center(1) = patch_ib(patch_id)%x_centroid + real(gp%x_periodicity, wp)*(x_domain%end - x_domain%beg) - if (.not. f_is_default(patch_ib(patch_id)%y_centroid)) center(2) = patch_ib(patch_id)%y_centroid + real(gp%y_periodicity, wp)*(y_domain%end - y_domain%beg) + if (.not. f_is_default(patch_ib(patch_id)%x_centroid)) center(1) = patch_ib(patch_id)%x_centroid + real(gp%x_periodicity, & + & wp)*(x_domain%end - x_domain%beg) + if (.not. f_is_default(patch_ib(patch_id)%y_centroid)) center(2) = patch_ib(patch_id)%y_centroid + real(gp%y_periodicity, & + & wp)*(y_domain%end - y_domain%beg) if (p > 0) then - if (.not. f_is_default(patch_ib(patch_id)%z_centroid)) center(3) = patch_ib(patch_id)%z_centroid + real(gp%z_periodicity, wp)*(z_domain%end - z_domain%beg) + if (.not. f_is_default(patch_ib(patch_id)%z_centroid)) center(3) = patch_ib(patch_id)%z_centroid & + & + real(gp%z_periodicity, wp)*(z_domain%end - z_domain%beg) end if - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) - rotation(:, :) = patch_ib(patch_id)%rotation_matrix(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) + rotation(:,:) = patch_ib(patch_id)%rotation_matrix(:,:) ! determine where we are located in space xyz_local = (/x_cc(i) - center(1), y_cc(j) - center(2), 0._wp/) @@ -687,13 +634,9 @@ contains gp%levelset_norm = matmul(rotation, normals(1:3)) else ! 2D models - call s_distance_normals_2D(patch_id, & - boundary_edge_count, & - xyz_local, normals, distance) + call s_distance_normals_2D(patch_id, boundary_edge_count, xyz_local, normals, distance) gp%levelset = -abs(distance) gp%levelset_norm = matmul(rotation, normals(1:3)) end if - end subroutine s_model_levelset - end module m_compute_levelset diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index f0178b44c6..76a4acea92 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -7,7 +7,6 @@ !> @brief Writes solution data, run-time stability diagnostics (ICFL, VCFL, CCFL, Rc), and probe/center-of-mass files module m_data_output - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -32,41 +31,27 @@ module m_data_output implicit none - private; - public :: s_initialize_data_output_module, & - s_open_run_time_information_file, & - s_open_com_files, & - s_open_probe_files, & - s_open_ib_state_file, & - s_write_run_time_information, & - s_write_data_files, & - s_write_serial_data_files, & - s_write_parallel_data_files, & - s_write_ib_data_file, & - s_write_com_files, & - s_write_probe_files, & - s_write_ib_state_file, & - s_close_run_time_information_file, & - s_close_com_files, & - s_close_probe_files, & - s_close_ib_state_file, & - s_finalize_data_output_module - - integer :: ib_state_unit = -1 !< I/O unit for IB state binary file - - real(wp), allocatable, dimension(:, :, :) :: icfl_sf !< ICFL stability criterion - real(wp), allocatable, dimension(:, :, :) :: vcfl_sf !< VCFL stability criterion - real(wp), allocatable, dimension(:, :, :) :: ccfl_sf !< CCFL stability criterion - real(wp), allocatable, dimension(:, :, :) :: Rc_sf !< Rc stability criterion - real(wp), public, allocatable, dimension(:, :) :: c_mass - $:GPU_DECLARE(create='[icfl_sf,vcfl_sf,ccfl_sf,Rc_sf,c_mass]') + private; + public :: s_initialize_data_output_module, s_open_run_time_information_file, s_open_com_files, s_open_probe_files, & + & s_open_ib_state_file, s_write_run_time_information, s_write_data_files, s_write_serial_data_files, & + & s_write_parallel_data_files, s_write_ib_data_file, s_write_com_files, s_write_probe_files, s_write_ib_state_file, & + & s_close_run_time_information_file, s_close_com_files, s_close_probe_files, s_close_ib_state_file, & + & s_finalize_data_output_module + + integer :: ib_state_unit = -1 !< I/O unit for IB state binary file + real(wp), allocatable, dimension(:,:,:) :: icfl_sf !< ICFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: vcfl_sf !< VCFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: ccfl_sf !< CCFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: Rc_sf !< Rc stability criterion + real(wp), public, allocatable, dimension(:,:) :: c_mass + $:GPU_DECLARE(create='[icfl_sf, vcfl_sf, ccfl_sf, Rc_sf, c_mass]') real(wp) :: icfl_max_loc, icfl_max_glb !< ICFL stability extrema on local and global grids real(wp) :: vcfl_max_loc, vcfl_max_glb !< VCFL stability extrema on local and global grids real(wp) :: ccfl_max_loc, ccfl_max_glb !< CCFL stability extrema on local and global grids real(wp) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids - $:GPU_DECLARE(create='[icfl_max_loc,icfl_max_glb,vcfl_max_loc,vcfl_max_glb]') - $:GPU_DECLARE(create='[ccfl_max_loc,ccfl_max_glb,Rc_min_loc,Rc_min_glb]') + $:GPU_DECLARE(create='[icfl_max_loc, icfl_max_glb, vcfl_max_loc, vcfl_max_glb]') + $:GPU_DECLARE(create='[ccfl_max_loc, ccfl_max_glb, Rc_min_loc, Rc_min_glb]') !> @name ICFL, VCFL, CCFL and Rc stability criteria extrema over all the time-steps !> @{ @@ -77,7 +62,6 @@ module m_data_output !> @} type(scalar_field), allocatable, dimension(:) :: q_cons_temp_ds - contains !> Write data files. Dispatch subroutine that replaces procedure pointer. @@ -88,43 +72,23 @@ contains !! @param bc_type Boundary condition type !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_write_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf - - type(scalar_field), & - intent(inout) :: q_T_sf - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_prim_vf - - integer, intent(in) :: t_step - - type(scalar_field), & - intent(inout), optional :: beta - - type(integer_field), & - dimension(1:num_dims, -1:1), & - intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + integer, intent(in) :: t_step + type(scalar_field), intent(inout), optional :: beta + type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type if (.not. parallel_io) then call s_write_serial_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) else call s_write_parallel_data_files(q_cons_vf, t_step, bc_type, beta) end if - end subroutine s_write_data_files - - !> The purpose of this subroutine is to open a new or pre- - !! existing run-time information file and append to it the - !! basic header information relevant to current simulation. - !! In general, this requires generating a table header for - !! those stability criteria which will be written at every - !! time-step. + !> The purpose of this subroutine is to open a new or pre- existing run-time information file and append to it the basic header + !! information relevant to current simulation. In general, this requires generating a table header for those stability criteria + !! which will be written at every time-step. impure subroutine s_open_run_time_information_file - character(LEN=name_len), parameter :: file_name = 'run_time.inf' !< !! Name of the run-time information file @@ -135,49 +99,34 @@ contains !! Creation date of the run-time information file ! Opening the run-time information file - file_path = trim(case_dir)//'/'//trim(file_name) - - open (3, FILE=trim(file_path), & - FORM='formatted', & - STATUS='replace') - - write (3, '(A)') 'Description: Stability information at '// & - 'each time-step of the simulation. This' - write (3, '(13X,A)') 'data is composed of the inviscid '// & - 'Courant–Friedrichs–Lewy (ICFL)' - write (3, '(13X,A)') 'number, the viscous CFL (VCFL) number, '// & - 'the capillary CFL (CCFL)' - write (3, '(13X,A)') 'number and the cell Reynolds (Rc) '// & - 'number. Please note that only' - write (3, '(13X,A)') 'those stability conditions pertinent '// & - 'to the physics included in' + file_path = trim(case_dir) // '/' // trim(file_name) + + open (3, FILE=trim(file_path), form='formatted', STATUS='replace') + + write (3, '(A)') 'Description: Stability information at ' // 'each time-step of the simulation. This' + write (3, '(13X,A)') 'data is composed of the inviscid ' // 'Courant-Friedrichs-Lewy (ICFL)' + write (3, '(13X,A)') 'number, the viscous CFL (VCFL) number, ' // 'the capillary CFL (CCFL)' + write (3, '(13X,A)') 'number and the cell Reynolds (Rc) ' // 'number. Please note that only' + write (3, '(13X,A)') 'those stability conditions pertinent ' // 'to the physics included in' write (3, '(13X,A)') 'the current computation are displayed.' call date_and_time(DATE=file_date) - write (3, '(A)') 'Date: '//file_date(5:6)//'/'// & - file_date(7:8)//'/'// & - file_date(3:4) + write (3, '(A)') 'Date: ' // file_date(5:6) // '/' // file_date(7:8) // '/' // file_date(3:4) write (3, '(A)') ''; write (3, '(A)') '' ! Generating table header for the stability criteria to be outputted - write (3, '(13X,A9,13X,A10,13X,A10,13X,A10)', advance="no") & - trim('Time-step'), trim('dt'), trim('Time'), trim('ICFL Max') + write (3, '(13X,A9,13X,A10,13X,A10,13X,A10)', advance="no") trim('Time-step'), trim('dt'), trim('Time'), trim('ICFL Max') if (viscous) then - write (3, '(13X,A10,13X,A16)', advance="no") & - trim('VCFL Max'), trim('Rc Min') + write (3, '(13X,A10,13X,A16)', advance="no") trim('VCFL Max'), trim('Rc Min') end if write (3, *) ! new line - end subroutine s_open_run_time_information_file - - !> This opens a formatted data file where the root processor - !! can write out the CoM information + !> This opens a formatted data file where the root processor can write out the CoM information impure subroutine s_open_com_files() - character(len=path_len + 3*name_len) :: file_path !< !! Relative path to the CoM file in the case directory integer :: i !< Generic loop iterator @@ -185,39 +134,25 @@ contains do i = 1, num_fluids ! Generating the relative path to the CoM data file write (file_path, '(A,I0,A)') '/fluid', i, '_com.dat' - file_path = trim(case_dir)//trim(file_path) + file_path = trim(case_dir) // trim(file_path) ! Creating the formatted data file and setting up its ! structure - open (i + 120, file=trim(file_path), & - form='formatted', & - position='append', & - status='unknown') + open (i + 120, file=trim(file_path), form='formatted', position='append', status='unknown') if (n == 0) then - write (i + 120, '(A)') ' Non-Dimensional Time '// & - ' Total Mass '// & - ' x-loc '// & - ' Total Volume ' - elseif (p == 0) then - write (i + 120, '(A)') ' Non-Dimensional Time '// & - ' Total Mass '// & - ' x-loc '// & - ' y-loc '// & - ' Total Volume ' + write (i + 120, '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' Total Volume ' + else if (p == 0) then + write (i + 120, & + & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' & + & // ' Total Volume ' else - write (i + 120, '(A)') ' Non-Dimensional Time '// & - ' Total Mass '// & - ' x-loc '// & - ' y-loc '// & - ' z-loc '// & - ' Total Volume ' + write (i + 120, & + & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' // ' z-loc ' & + & // ' Total Volume ' end if end do end subroutine s_open_com_files - - !> This opens a formatted data file where the root processor - !! can write out flow probe information + !> This opens a formatted data file where the root processor can write out flow probe information impure subroutine s_open_probe_files - character(LEN=path_len + 3*name_len) :: file_path !< !! Relative path to the probe data file in the case directory @@ -227,84 +162,65 @@ contains do i = 1, num_probes ! Generating the relative path to the data file write (file_path, '(A,I0,A)') '/D/probe', i, '_prim.dat' - file_path = trim(case_dir)//trim(file_path) + file_path = trim(case_dir) // trim(file_path) ! Creating the formatted data file and setting up its ! structure inquire (file=trim(file_path), exist=file_exist) if (file_exist) then - open (i + 30, FILE=trim(file_path), & - FORM='formatted', & - STATUS='old', & - POSITION='append') + open (i + 30, FILE=trim(file_path), form='formatted', STATUS='old', POSITION='append') else - open (i + 30, FILE=trim(file_path), & - FORM='formatted', & - STATUS='unknown') + open (i + 30, FILE=trim(file_path), form='formatted', STATUS='unknown') end if end do if (integral_wrt) then do i = 1, num_integrals write (file_path, '(A,I0,A)') '/D/integral', i, '_prim.dat' - file_path = trim(case_dir)//trim(file_path) + file_path = trim(case_dir) // trim(file_path) - open (i + 70, FILE=trim(file_path), & - FORM='formatted', & - POSITION='append', & - STATUS='unknown') + open (i + 70, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') end do end if - end subroutine s_open_probe_files - impure subroutine s_open_ib_state_file character(len=path_len + 2*name_len) :: file_loc - integer :: ios + integer :: ios write (file_loc, '(A)') 'ib_state.dat' - file_loc = trim(case_dir)//'/D/'//trim(file_loc) - open (newunit=ib_state_unit, file=trim(file_loc), & - form='unformatted', & - access='stream', & - status='replace', & - iostat=ios) - if (ios /= 0) call s_mpi_abort('Cannot open IB state output file: '//trim(file_loc)) + file_loc = trim(case_dir) // '/D/' // trim(file_loc) + open (newunit=ib_state_unit, file=trim(file_loc), form='unformatted', access='stream', status='replace', iostat=ios) + if (ios /= 0) call s_mpi_abort('Cannot open IB state output file: ' // trim(file_loc)) end subroutine s_open_ib_state_file - - !> The goal of the procedure is to output to the run-time - !! information file the stability criteria extrema in the - !! entire computational domain and at the given time-step. - !! Moreover, the subroutine is also in charge of tracking - !! these stability criteria extrema over all time-steps. - !! @param q_prim_vf Cell-average primitive variables - !! @param t_step Current time step + !> The goal of the procedure is to output to the run-time information file the stability criteria extrema in the entire + !! computational domain and at the given time-step. Moreover, the subroutine is also in charge of tracking these stability + !! criteria extrema over all time-steps. + !! @param q_prim_vf Cell-average primitive variables + !! @param t_step Current time step impure subroutine s_write_run_time_information(q_prim_vf, t_step) - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer, intent(in) :: t_step - - real(wp) :: rho !< Cell-avg. density + integer, intent(in) :: t_step + real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction real(wp), dimension(3) :: vel !< Cell-avg. velocity #:else real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction - real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity + real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity #:endif - real(wp) :: vel_sum !< Cell-avg. velocity sum - real(wp) :: pres !< Cell-avg. pressure - real(wp) :: gamma !< Cell-avg. sp. heat ratio - real(wp) :: pi_inf !< Cell-avg. liquid stiffness function - real(wp) :: qv !< Cell-avg. internal energy reference value - real(wp) :: c !< Cell-avg. sound speed - real(wp) :: H !< Cell-avg. enthalpy + real(wp) :: vel_sum !< Cell-avg. velocity sum + real(wp) :: pres !< Cell-avg. pressure + real(wp) :: gamma !< Cell-avg. sp. heat ratio + real(wp) :: pi_inf !< Cell-avg. liquid stiffness function + real(wp) :: qv !< Cell-avg. internal energy reference value + real(wp) :: c !< Cell-avg. sound speed + real(wp) :: H !< Cell-avg. enthalpy real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers - integer :: j, k, l + integer :: j, k, l ! Computing Stability Criteria at Current Time-step - $:GPU_PARALLEL_LOOP(collapse=3, private='[j,k,l,vel, alpha, Re, rho, vel_sum, pres, gamma, pi_inf, c, H, qv]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, vel, alpha, Re, rho, vel_sum, pres, gamma, pi_inf, c, H, qv]') do l = 0, p do k = 0, n do j = 0, m @@ -317,7 +233,6 @@ contains else call s_compute_stability_from_dt(vel, c, rho, Re, j, k, l, icfl_sf) end if - end do end do end do @@ -331,7 +246,7 @@ contains $:GPU_UPDATE(host='[icfl_sf]') if (viscous) then - $:GPU_UPDATE(host='[vcfl_sf,Rc_sf]') + $:GPU_UPDATE(host='[vcfl_sf, Rc_sf]') end if icfl_max_loc = maxval(icfl_sf) @@ -354,12 +269,8 @@ contains ! Determining global stability criteria extrema at current time-step if (num_procs > 1) then - call s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, & - vcfl_max_loc, & - Rc_min_loc, & - icfl_max_glb, & - vcfl_max_glb, & - Rc_min_glb) + call s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & + & Rc_min_glb) else icfl_max_glb = icfl_max_loc if (viscous) vcfl_max_glb = vcfl_max_loc @@ -376,20 +287,17 @@ contains ! Outputting global stability criteria extrema at current time-step if (proc_rank == 0) then - write (3, '(13X,I9,13X,F10.6,13X,F10.6,13X,F10.6)', advance="no") & - t_step, dt, mytime, icfl_max_glb + write (3, '(13X,I9,13X,F10.6,13X,F10.6,13X,F10.6)', advance="no") t_step, dt, mytime, icfl_max_glb if (viscous) then - write (3, '(13X,F10.6,13X,ES16.6)', advance="no") & - vcfl_max_glb, & - Rc_min_glb + write (3, '(13X,F10.6,13X,ES16.6)', advance="no") vcfl_max_glb, Rc_min_glb end if write (3, *) ! new line if (.not. f_approx_equal(icfl_max_glb, icfl_max_glb)) then call s_mpi_abort('ICFL is NaN. Exiting.') - elseif (icfl_max_glb > 1._wp) then + else if (icfl_max_glb > 1._wp) then print *, 'icfl', icfl_max_glb call s_mpi_abort('ICFL is greater than 1.0. Exiting.') end if @@ -397,7 +305,7 @@ contains if (viscous) then if (.not. f_approx_equal(vcfl_max_glb, vcfl_max_glb)) then call s_mpi_abort('VCFL is NaN. Exiting.') - elseif (vcfl_max_glb > 1._wp) then + else if (vcfl_max_glb > 1._wp) then print *, 'vcfl', vcfl_max_glb call s_mpi_abort('VCFL is greater than 1.0. Exiting.') end if @@ -405,27 +313,22 @@ contains end if call s_mpi_barrier() - end subroutine s_write_run_time_information - - !> The goal of this subroutine is to output the grid and - !! conservative variables data files for given time-step. - !! @param q_cons_vf Cell-average conservative variables - !! @param q_T_sf Temperature scalar field - !! @param q_prim_vf Cell-average primitive variables - !! @param t_step Current time-step - !! @param bc_type Boundary condition type - !! @param beta Eulerian void fraction from lagrangian bubbles + !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. + !! @param q_cons_vf Cell-average conservative variables + !! @param q_T_sf Temperature scalar field + !! @param q_prim_vf Cell-average primitive variables + !! @param t_step Current time-step + !! @param bc_type Boundary condition type + !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_write_serial_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) - - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - type(scalar_field), intent(inout) :: q_T_sf - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: t_step - type(scalar_field), intent(inout), optional :: beta + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + integer, intent(in) :: t_step + type(scalar_field), intent(inout), optional :: beta type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type - - character(LEN=path_len + 2*name_len) :: t_step_dir !< + character(LEN=path_len + 2*name_len) :: t_step_dir !< !! Relative path to the current time-step directory character(LEN=path_len + 3*name_len) :: file_path !< @@ -435,62 +338,46 @@ contains !! Logical used to check existence of current time-step directory character(LEN=15) :: FMT - - integer :: i, j, k, l, r - - real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params + integer :: i, j, k, l, r + real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params ! Creating or overwriting the time-step root directory - write (t_step_dir, '(A,I0,A,I0)') trim(case_dir)//'/p_all' + write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all' ! Creating or overwriting the current time-step directory - write (t_step_dir, '(a,i0,a,i0)') trim(case_dir)//'/p_all/p', & - proc_rank, '/', t_step + write (t_step_dir, '(a,i0,a,i0)') trim(case_dir) // '/p_all/p', proc_rank, '/', t_step - file_path = trim(t_step_dir)//'/.' + file_path = trim(t_step_dir) // '/.' call my_inquire(file_path, file_exist) if (file_exist) call s_delete_directory(trim(t_step_dir)) call s_create_directory(trim(t_step_dir)) ! Writing the grid data file in the x-direction - file_path = trim(t_step_dir)//'/x_cb.dat' + file_path = trim(t_step_dir) // '/x_cb.dat' - open (2, FILE=trim(file_path), & - FORM='unformatted', & - STATUS='new') + open (2, FILE=trim(file_path), form='unformatted', STATUS='new') write (2) x_cb(-1:m); close (2) ! Writing the grid data files in the y- and z-directions if (n > 0) then + file_path = trim(t_step_dir) // '/y_cb.dat' - file_path = trim(t_step_dir)//'/y_cb.dat' - - open (2, FILE=trim(file_path), & - FORM='unformatted', & - STATUS='new') + open (2, FILE=trim(file_path), form='unformatted', STATUS='new') write (2) y_cb(-1:n); close (2) if (p > 0) then + file_path = trim(t_step_dir) // '/z_cb.dat' - file_path = trim(t_step_dir)//'/z_cb.dat' - - open (2, FILE=trim(file_path), & - FORM='unformatted', & - STATUS='new') + open (2, FILE=trim(file_path), form='unformatted', STATUS='new') write (2) z_cb(-1:p); close (2) - end if - end if ! Writing the conservative variables data files do i = 1, sys_size - write (file_path, '(A,I0,A)') trim(t_step_dir)//'/q_cons_vf', & - i, '.dat' + write (file_path, '(A,I0,A)') trim(t_step_dir) // '/q_cons_vf', i, '.dat' - open (2, FILE=trim(file_path), & - FORM='unformatted', & - STATUS='new') + open (2, FILE=trim(file_path), form='unformatted', STATUS='new') write (2) q_cons_vf(i)%sf(0:m, 0:n, 0:p); close (2) end do @@ -498,12 +385,9 @@ contains ! Lagrangian beta (void fraction) written as q_cons_vf(sys_size+1) to ! match the parallel I/O path and allow post_process to read it. if (bubbles_lagrange) then - write (file_path, '(A,I0,A)') trim(t_step_dir)//'/q_cons_vf', & - sys_size + 1, '.dat' + write (file_path, '(A,I0,A)') trim(t_step_dir) // '/q_cons_vf', sys_size + 1, '.dat' - open (2, FILE=trim(file_path), & - FORM='unformatted', & - STATUS='new') + open (2, FILE=trim(file_path), form='unformatted', STATUS='new') write (2) beta%sf(0:m, 0:n, 0:p); close (2) end if @@ -511,12 +395,9 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A)') trim(t_step_dir)//'/pb', & - sys_size + (i - 1)*nnode + r, '.dat' + write (file_path, '(A,I0,A)') trim(t_step_dir) // '/pb', sys_size + (i - 1)*nnode + r, '.dat' - open (2, FILE=trim(file_path), & - FORM='unformatted', & - STATUS='new') + open (2, FILE=trim(file_path), form='unformatted', STATUS='new') write (2) pb_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) end do @@ -524,12 +405,9 @@ contains do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A)') trim(t_step_dir)//'/mv', & - sys_size + (i - 1)*nnode + r, '.dat' + write (file_path, '(A,I0,A)') trim(t_step_dir) // '/mv', sys_size + (i - 1)*nnode + r, '.dat' - open (2, FILE=trim(file_path), & - FORM='unformatted', & - STATUS='new') + open (2, FILE=trim(file_path), form='unformatted', STATUS='new') write (2) mv_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) end do @@ -560,8 +438,8 @@ contains end if ! writing an output directory - write (t_step_dir, '(A,I0,A,I0)') trim(case_dir)//'/D' - file_path = trim(t_step_dir)//'/.' + write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/D' + file_path = trim(t_step_dir) // '/.' inquire (FILE=trim(file_path), EXIST=file_exist) @@ -570,7 +448,7 @@ contains if ((prim_vars_wrt .or. (n == 0 .and. p == 0)) .and. (.not. igr)) then call s_convert_conservative_to_primitive_variables(q_cons_vf, q_T_sf, q_prim_vf, idwint) do i = 1, sys_size - $:GPU_UPDATE(host='[q_prim_vf(i)%sf(:,:,:)]') + $:GPU_UPDATE(host='[q_prim_vf(i)%sf(:, :, :)]') end do ! q_prim_vf(bubxb) stores the value of nb needed in riemann solvers, so replace with true primitive value (=1._wp) if (qbmm) then @@ -578,12 +456,11 @@ contains end if end if - !1D + ! 1D if (n == 0 .and. p == 0) then - if (model_eqns == 2 .and. (.not. igr)) then do i = 1, sys_size - write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/prim.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/prim.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -599,7 +476,7 @@ contains end if do i = 1, sys_size - write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/cons.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -611,7 +488,8 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -622,7 +500,8 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -643,7 +522,7 @@ contains ! 2D if ((n > 0) .and. (p == 0)) then do i = 1, sys_size - write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/cons.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m do k = 0, n @@ -655,7 +534,7 @@ contains end do if (present(beta)) then - write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/beta.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/beta.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m do k = 0, n @@ -669,7 +548,8 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -682,7 +562,8 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -697,16 +578,14 @@ contains if (prim_vars_wrt .and. (.not. igr)) then do i = 1, sys_size - write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/prim.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/prim.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m do k = 0, n - if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) & - .or. & - ((i >= adv_idx%beg) .and. (i <= adv_idx%end)) & - ) then + if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) .or. ((i >= adv_idx%beg) .and. (i <= adv_idx%end)) & + & ) then write (2, FMT) x_cb(j), y_cb(k), q_cons_vf(i)%sf(j, k, 0) else write (2, FMT) x_cb(j), y_cb(k), q_prim_vf(i)%sf(j, k, 0) @@ -728,7 +607,7 @@ contains ! 3D if (p > 0) then do i = 1, sys_size - write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/cons.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m do k = 0, n @@ -743,7 +622,7 @@ contains end do if (present(beta)) then - write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/beta.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/beta.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m do k = 0, n @@ -760,7 +639,8 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/pres.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -775,7 +655,8 @@ contains end do do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/mv.', i, '.', r, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -792,19 +673,15 @@ contains if (prim_vars_wrt .and. (.not. igr)) then do i = 1, sys_size - write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir)//'/prim.', i, '.', proc_rank, '.', t_step, '.dat' + write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/prim.', i, '.', proc_rank, '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m do k = 0, n do l = 0, p - if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) & - .or. & - ((i >= adv_idx%beg) .and. (i <= adv_idx%end)) & - .or. & - ((i >= chemxb) .and. (i <= chemxe)) & - ) then + if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) .or. ((i >= adv_idx%beg) & + & .and. (i <= adv_idx%end)) .or. ((i >= chemxb) .and. (i <= chemxe))) then write (2, FMT) x_cb(j), y_cb(k), z_cb(l), q_cons_vf(i)%sf(j, k, l) else write (2, FMT) x_cb(j), y_cb(k), z_cb(l), q_prim_vf(i)%sf(j, k, l) @@ -818,41 +695,32 @@ contains end do end if end if - end subroutine s_write_serial_data_files - - !> The goal of this subroutine is to output the grid and - !! conservative variables data files for given time-step. - !! @param q_cons_vf Cell-average conservative variables - !! @param t_step Current time-step - !! @param bc_type Boundary condition type - !! @param beta Eulerian void fraction from lagrangian bubbles + !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. + !! @param q_cons_vf Cell-average conservative variables + !! @param t_step Current time-step + !! @param bc_type Boundary condition type + !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_write_parallel_data_files(q_cons_vf, t_step, bc_type, beta) - - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer, intent(in) :: t_step - type(scalar_field), intent(inout), optional :: beta - type(integer_field), & - dimension(1:num_dims, -1:1), & - intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + integer, intent(in) :: t_step + type(scalar_field), intent(inout), optional :: beta + type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type #ifdef MFC_MPI - integer :: ifile, ierr, data_size - integer, dimension(MPI_STATUS_SIZE) :: status - integer(kind=MPI_OFFSET_kind) :: disp - integer(kind=MPI_OFFSET_kind) :: m_MOK, n_MOK, p_MOK - integer(kind=MPI_OFFSET_kind) :: WP_MOK, var_MOK, str_MOK - integer(kind=MPI_OFFSET_kind) :: NVARS_MOK - integer(kind=MPI_OFFSET_kind) :: MOK - + integer :: ifile, ierr, data_size + integer, dimension(MPI_STATUS_SIZE) :: status + integer(kind=MPI_OFFSET_kind) :: disp + integer(kind=MPI_OFFSET_kind) :: m_MOK, n_MOK, p_MOK + integer(kind=MPI_OFFSET_kind) :: WP_MOK, var_MOK, str_MOK + integer(kind=MPI_OFFSET_kind) :: NVARS_MOK + integer(kind=MPI_OFFSET_kind) :: MOK character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist, dir_check - character(len=10) :: t_step_string - - integer :: i !< Generic loop iterator - - integer :: alt_sys !< Altered system size for the lagrangian subgrid bubble model + logical :: file_exist, dir_check + character(len=10) :: t_step_string + integer :: i !< Generic loop iterator + integer :: alt_sys !< Altered system size for the lagrangian subgrid bubble model ! Down sampling variables integer :: m_ds, n_ds, p_ds @@ -860,8 +728,7 @@ contains integer :: m_glb_save, n_glb_save, p_glb_save ! Global save size if (down_sample) then - call s_downsample_data(q_cons_vf, q_cons_temp_ds, & - m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) + call s_downsample_data(q_cons_vf, q_cons_temp_ds, m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) end if if (present(beta)) then @@ -871,7 +738,6 @@ contains end if if (file_per_process) then - call s_int_to_str(t_step, t_step_string) ! Initialize MPI data I/O @@ -886,7 +752,7 @@ contains end if if (proc_rank == 0) then - file_loc = trim(case_dir)//'/restart_data/lustre_'//trim(t_step_string) + file_loc = trim(case_dir) // '/restart_data/lustre_' // trim(t_step_string) call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then call s_create_directory(trim(file_loc)) @@ -901,13 +767,12 @@ contains ! Open the file to write all flow variables write (file_loc, '(I0,A,i7.7,A)') t_step, '_', proc_rank, '.dat' - file_loc = trim(case_dir)//'/restart_data/lustre_'//trim(t_step_string)//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data/lustre_' // trim(t_step_string) // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist .and. proc_rank == 0) then call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) end if - call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) if (down_sample) then ! Size of local arrays @@ -937,32 +802,28 @@ contains do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - !Write pb and mv for non-polytropic qbmm + ! Write pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if else if (down_sample) then - do i = 1, sys_size !TODO: check if correct (sys_size + do i = 1, sys_size ! TODO: check if correct (sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_WRITE_ALL(ifile, q_cons_temp_ds(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, q_cons_temp_ds(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do else - do i = 1, sys_size !TODO: check if correct (sys_size + do i = 1, sys_size ! TODO: check if correct (sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if end if @@ -973,20 +834,19 @@ contains if (ib) then call s_initialize_mpi_data(q_cons_vf, ib_markers) - elseif (present(beta)) then + else if (present(beta)) then call s_initialize_mpi_data(q_cons_vf, beta=beta) else call s_initialize_mpi_data(q_cons_vf) end if write (file_loc, '(I0,A)') t_step, '.dat' - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist .and. proc_rank == 0) then call MPI_FILE_DELETE(file_loc, mpi_info_int, ierr) end if - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) @@ -1008,12 +868,10 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - !Write pb and mv for non-polytropic qbmm + ! Write pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) @@ -1021,23 +879,19 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if else - do i = 1, sys_size !TODO: check if correct (sys_size + do i = 1, sys_size ! TODO: check if correct (sys_size var_MOK = int(i, MPI_OFFSET_KIND) ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if @@ -1048,15 +902,13 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(sys_size + 1), & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(sys_size + 1)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(sys_size + 1), 'native', mpi_info_int, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(sys_size + 1)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end if call MPI_FILE_CLOSE(ifile, ierr) - !Write ib data + ! Write ib data if (ib) then call s_write_parallel_ib_data(t_step) ! write (file_loc, '(A)') 'ib.dat' @@ -1073,47 +925,37 @@ contains ! MPI_INTEGER, status, ierr) ! call MPI_FILE_CLOSE(ifile, ierr) end if - end if #endif - end subroutine s_write_parallel_data_files - !> @brief Writes immersed boundary marker data to a serial (per-processor) unformatted file. subroutine s_write_serial_ib_data(time_step) - - integer, intent(in) :: time_step + integer, intent(in) :: time_step character(LEN=path_len + 2*name_len) :: file_path character(LEN=path_len + 2*name_len) :: t_step_dir ! Creating or overwriting the time-step root directory - write (t_step_dir, '(A,I0,A,I0)') trim(case_dir)//'/p_all' - write (t_step_dir, '(a,i0,a,i0)') trim(case_dir)//'/p_all/p', & - proc_rank, '/', time_step - write (file_path, '(A,I0,A)') trim(t_step_dir)//'/ib_data.dat' + write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all' + write (t_step_dir, '(a,i0,a,i0)') trim(case_dir) // '/p_all/p', proc_rank, '/', time_step + write (file_path, '(A,I0,A)') trim(t_step_dir) // '/ib_data.dat' - open (2, FILE=trim(file_path), & - FORM='unformatted', & - STATUS='new') + open (2, FILE=trim(file_path), form='unformatted', STATUS='new') $:GPU_UPDATE(host='[ib_markers%sf]') write (2) ib_markers%sf(0:m, 0:n, 0:p); close (2) - - end subroutine - + end subroutine s_write_serial_ib_data !> @brief Writes immersed boundary marker data in parallel using MPI I/O. subroutine s_write_parallel_ib_data(time_step) - integer, intent(in) :: time_step #ifdef MFC_MPI character(LEN=path_len + 2*name_len) :: file_loc - integer(kind=MPI_OFFSET_kind) :: disp - integer(kind=MPI_OFFSET_kind) :: m_MOK, n_MOK, p_MOK - integer(kind=MPI_OFFSET_kind) :: WP_MOK, var_MOK, MOK - integer :: ifile, ierr, data_size - integer, dimension(MPI_STATUS_SIZE) :: status + integer(kind=MPI_OFFSET_kind) :: disp + integer(kind=MPI_OFFSET_kind) :: m_MOK, n_MOK, p_MOK + integer(kind=MPI_OFFSET_kind) :: WP_MOK, var_MOK, MOK + integer :: ifile, ierr, data_size + integer, dimension(MPI_STATUS_SIZE) :: status $:GPU_UPDATE(host='[ib_markers%sf]') @@ -1126,27 +968,20 @@ contains MOK = int(1._wp, MPI_OFFSET_KIND) write (file_loc, '(A)') 'ib.dat' - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) - call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - mpi_info_int, ifile, ierr) + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) + call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) var_MOK = int(sys_size + 1, MPI_OFFSET_KIND) disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1 + int(time_step/t_step_save)) if (time_step == 0) disp = 0 - call MPI_FILE_SET_VIEW(ifile, disp, MPI_INTEGER, MPI_IO_IB_DATA%view, & - 'native', mpi_info_int, ierr) - call MPI_FILE_WRITE_ALL(ifile, MPI_IO_IB_DATA%var%sf, data_size, & - MPI_INTEGER, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, MPI_INTEGER, MPI_IO_IB_DATA%view, 'native', mpi_info_int, ierr) + call MPI_FILE_WRITE_ALL(ifile, MPI_IO_IB_DATA%var%sf, data_size, MPI_INTEGER, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) - #endif - end subroutine s_write_parallel_ib_data - !> @brief Dispatches immersed boundary data output to the serial or parallel writer. subroutine s_write_ib_data_file(time_step) - integer, intent(in) :: time_step if (parallel_io) then @@ -1154,38 +989,24 @@ contains else call s_write_serial_ib_data(time_step) end if - end subroutine s_write_ib_data_file - !> @brief Writes IB state records to D/ib_state.dat. Must be called only on rank 0. impure subroutine s_write_ib_state_file() - integer :: i do i = 1, num_ibs - write (ib_state_unit) mytime, i, & - patch_ib(i)%force, & - patch_ib(i)%torque, & - patch_ib(i)%vel, & - patch_ib(i)%angular_vel, & - patch_ib(i)%angles, & - patch_ib(i)%x_centroid, & - patch_ib(i)%y_centroid, & - patch_ib(i)%z_centroid + write (ib_state_unit) mytime, i, patch_ib(i)%force, patch_ib(i)%torque, patch_ib(i)%vel, patch_ib(i)%angular_vel, & + & patch_ib(i)%angles, patch_ib(i)%x_centroid, patch_ib(i)%y_centroid, patch_ib(i)%z_centroid end do - end subroutine s_write_ib_state_file - - !> This writes a formatted data file where the root processor - !! can write out the CoM information - !! @param t_step Current time-step - !! @param c_mass_in Center of mass information + !> This writes a formatted data file where the root processor can write out the CoM information + !! @param t_step Current time-step + !! @param c_mass_in Center of mass information impure subroutine s_write_com_files(t_step, c_mass_in) - - integer, intent(in) :: t_step + integer, intent(in) :: t_step real(wp), dimension(num_fluids, 5), intent(in) :: c_mass_in - integer :: i !< Generic loop iterator - real(wp) :: nondim_time !< Non-dimensional time + integer :: i !< Generic loop iterator + real(wp) :: nondim_time !< Non-dimensional time ! Non-dimensional time calculation if (t_step_old /= dflt_int) then @@ -1197,90 +1018,68 @@ contains if (proc_rank == 0) then if (n == 0) then ! 1D simulation do i = 1, num_fluids ! Loop through fluids - write (i + 120, '(6X,4F24.12)') & - nondim_time, & - c_mass_in(i, 1), & - c_mass_in(i, 2), & - c_mass_in(i, 5) + write (i + 120, '(6X,4F24.12)') nondim_time, c_mass_in(i, 1), c_mass_in(i, 2), c_mass_in(i, 5) end do - elseif (p == 0) then ! 2D simulation + else if (p == 0) then ! 2D simulation do i = 1, num_fluids ! Loop through fluids - write (i + 120, '(6X,5F24.12)') & - nondim_time, & - c_mass_in(i, 1), & - c_mass_in(i, 2), & - c_mass_in(i, 3), & - c_mass_in(i, 5) + write (i + 120, '(6X,5F24.12)') nondim_time, c_mass_in(i, 1), c_mass_in(i, 2), c_mass_in(i, 3), c_mass_in(i, 5) end do else ! 3D simulation do i = 1, num_fluids ! Loop through fluids - write (i + 120, '(6X,6F24.12)') & - nondim_time, & - c_mass_in(i, 1), & - c_mass_in(i, 2), & - c_mass_in(i, 3), & - c_mass_in(i, 4), & - c_mass_in(i, 5) + write (i + 120, '(6X,6F24.12)') nondim_time, c_mass_in(i, 1), c_mass_in(i, 2), c_mass_in(i, 3), c_mass_in(i, & + & 4), c_mass_in(i, 5) end do end if end if - end subroutine s_write_com_files - - !> This writes a formatted data file for the flow probe information - !! @param t_step Current time-step - !! @param q_cons_vf Conservative variables - !! @param accel_mag Acceleration magnitude information + !> This writes a formatted data file for the flow probe information + !! @param t_step Current time-step + !! @param q_cons_vf Conservative variables + !! @param accel_mag Acceleration magnitude information impure subroutine s_write_probe_files(t_step, q_cons_vf, accel_mag) - - integer, intent(in) :: t_step + integer, intent(in) :: t_step type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(wp), dimension(0:m, 0:n, 0:p), intent(in) :: accel_mag - - real(wp), dimension(-1:m) :: distx - real(wp), dimension(-1:n) :: disty - real(wp), dimension(-1:p) :: distz + real(wp), dimension(0:m, 0:n, 0:p), intent(in) :: accel_mag + real(wp), dimension(-1:m) :: distx + real(wp), dimension(-1:n) :: disty + real(wp), dimension(-1:p) :: distz ! The cell-averaged partial densities, density, velocity, pressure, ! volume fractions, specific heat ratio function, liquid stiffness ! function, and sound speed. - real(wp) :: lit_gamma, nbub - real(wp) :: rho - real(wp), dimension(num_vels) :: vel - real(wp) :: pres - real(wp) :: ptilde - real(wp) :: ptot - real(wp) :: alf - real(wp) :: alfgr + real(wp) :: lit_gamma, nbub + real(wp) :: rho + real(wp), dimension(num_vels) :: vel + real(wp) :: pres + real(wp) :: ptilde + real(wp) :: ptot + real(wp) :: alf + real(wp) :: alfgr real(wp), dimension(num_fluids) :: alpha - real(wp) :: gamma - real(wp) :: pi_inf - real(wp) :: qv - real(wp) :: c - real(wp) :: M00, M10, M01, M20, M11, M02 - real(wp) :: varR, varV - real(wp), dimension(Nb) :: nR, R, nRdot, Rdot - real(wp) :: nR3 - real(wp) :: accel - real(wp) :: int_pres - real(wp) :: max_pres - real(wp), dimension(2) :: Re - real(wp), dimension(6) :: tau_e - real(wp) :: G_local - real(wp) :: dyn_p, T - real(wp) :: damage_state - - integer :: i, j, k, l, s, d !< Generic loop iterator - - real(wp) :: nondim_time !< Non-dimensional time - - real(wp) :: tmp !< + real(wp) :: gamma + real(wp) :: pi_inf + real(wp) :: qv + real(wp) :: c + real(wp) :: M00, M10, M01, M20, M11, M02 + real(wp) :: varR, varV + real(wp), dimension(Nb) :: nR, R, nRdot, Rdot + real(wp) :: nR3 + real(wp) :: accel + real(wp) :: int_pres + real(wp) :: max_pres + real(wp), dimension(2) :: Re + real(wp), dimension(6) :: tau_e + real(wp) :: G_local + real(wp) :: dyn_p, T + real(wp) :: damage_state + integer :: i, j, k, l, s, d !< Generic loop iterator + real(wp) :: nondim_time !< Non-dimensional time + real(wp) :: tmp !< !! Temporary variable to store quantity for mpi_allreduce - integer :: npts !< Number of included integral points + integer :: npts !< Number of included integral points real(wp) :: rad, thickness !< For integral quantities - logical :: trigger !< For integral quantities - + logical :: trigger !< For integral quantities real(wp) :: rhoYks(1:num_species) T = dflt_T_guess @@ -1345,12 +1144,10 @@ contains ! Computing/Sharing necessary state variables if (elasticity) then - call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, & - rho, gamma, pi_inf, qv, & - Re, G_local, fluid_pp(:)%G) + call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, rho, gamma, pi_inf, qv, Re, G_local, & + & fluid_pp(:)%G) else - call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, & - rho, gamma, pi_inf, qv) + call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, rho, gamma, pi_inf, qv) end if do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k, l)/rho @@ -1364,17 +1161,12 @@ contains G_local = G_local*max((1._wp - damage_state), 0._wp) end if - call s_compute_pressure( & - q_cons_vf(1)%sf(j - 2, k, l), & - q_cons_vf(alf_idx)%sf(j - 2, k, l), & - dyn_p, pi_inf, gamma, rho, qv, rhoYks(:), pres, T, & - q_cons_vf(stress_idx%beg)%sf(j - 2, k, l), & - q_cons_vf(mom_idx%beg)%sf(j - 2, k, l), G_local) + call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k, l), q_cons_vf(alf_idx)%sf(j - 2, k, l), dyn_p, pi_inf, & + & gamma, rho, qv, rhoYks(:), pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, k, l), & + & q_cons_vf(mom_idx%beg)%sf(j - 2, k, l), G_local) else - call s_compute_pressure( & - q_cons_vf(E_idx)%sf(j - 2, k, l), & - q_cons_vf(alf_idx)%sf(j - 2, k, l), & - dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) + call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k, l), q_cons_vf(alf_idx)%sf(j - 2, k, l), dyn_p, & + & pi_inf, gamma, rho, qv, rhoYks, pres, T) end if if (model_eqns == 4) then @@ -1431,12 +1223,12 @@ contains end if ! Compute mixture sound Speed - call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, 0._wp, c, qv) + call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, & + & 0._wp, c, qv) accel = accel_mag(j - 2, k, l) end if - elseif (p == 0) then ! 2D simulation + else if (p == 0) then ! 2D simulation if (chemistry) then do d = 1, num_species rhoYks(d) = q_cons_vf(chemxb + d - 1)%sf(j - 2, k - 2, l) @@ -1460,9 +1252,8 @@ contains l = 0 ! Computing/Sharing necessary state variables - call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l, & - rho, gamma, pi_inf, qv, & - Re, G_local, fluid_pp(:)%G) + call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l, rho, gamma, pi_inf, qv, Re, G_local, & + & fluid_pp(:)%G) do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k - 2, l)/rho end do @@ -1475,20 +1266,13 @@ contains G_local = G_local*max((1._wp - damage_state), 0._wp) end if - call s_compute_pressure( & - q_cons_vf(1)%sf(j - 2, k - 2, l), & - q_cons_vf(alf_idx)%sf(j - 2, k - 2, l), & - dyn_p, pi_inf, gamma, rho, qv, & - rhoYks, & - pres, & - T, & - q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l), & - q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l), G_local) + call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k - 2, l), q_cons_vf(alf_idx)%sf(j - 2, k - 2, l), & + & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, & + & q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l), & + & q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l), G_local) else - call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l), & - q_cons_vf(alf_idx)%sf(j - 2, k - 2, l), & - dyn_p, pi_inf, gamma, rho, qv, & - rhoYks, pres, T) + call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l), q_cons_vf(alf_idx)%sf(j - 2, k - 2, l), & + & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) end if if (model_eqns == 4) then @@ -1521,9 +1305,8 @@ contains Rdot(:) = nRdot(:)/nbub end if ! Compute mixture sound speed - call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, 0._wp, c, qv) - + call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, & + & 0._wp, 0._wp, c, qv) end if end if else ! 3D @@ -1550,9 +1333,8 @@ contains if (l == 1) l = 2 ! Pick first point if probe is at edge ! Computing/Sharing necessary state variables - call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l - 2, & - rho, gamma, pi_inf, qv, & - Re, G_local, fluid_pp(:)%G) + call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l - 2, rho, gamma, pi_inf, qv, Re, & + & G_local, fluid_pp(:)%G) do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k - 2, l - 2)/rho end do @@ -1571,23 +1353,18 @@ contains G_local = G_local*max((1._wp - damage_state), 0._wp) end if - call s_compute_pressure( & - q_cons_vf(1)%sf(j - 2, k - 2, l - 2), & - q_cons_vf(alf_idx)%sf(j - 2, k - 2, l - 2), & - dyn_p, pi_inf, gamma, rho, qv, & - rhoYks, pres, T, & - q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l - 2), & - q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l - 2), G_local) + call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k - 2, l - 2), q_cons_vf(alf_idx)%sf(j - 2, k - 2, & + & l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, & + & q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l - 2), & + & q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l - 2), G_local) else - call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l - 2), & - q_cons_vf(alf_idx)%sf(j - 2, k - 2, l - 2), & - dyn_p, pi_inf, gamma, rho, qv, & - rhoYks, pres, T) + call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l - 2), q_cons_vf(alf_idx)%sf(j - 2, & + & k - 2, l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) end if ! Compute mixture sound speed - call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, & - ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, 0._wp, c, qv) + call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, & + & 0._wp, 0._wp, c, qv) accel = accel_mag(j - 2, k - 2, l - 2) end if @@ -1635,127 +1412,47 @@ contains if (n == 0) then if (bubbles_euler .and. (num_fluids <= 2)) then if (qbmm) then - write (i + 30, '(6x,f12.6,14f28.16)') & - nondim_time, & - rho, & - vel(1), & - pres, & - alf, & - R(1), & - Rdot(1), & - nR(1), & - nRdot(1), & - varR, & - varV, & - M10, & - M01, & - M20, & - M02 + write (i + 30, '(6x,f12.6,14f28.16)') nondim_time, rho, vel(1), pres, alf, R(1), Rdot(1), nR(1), & + & nRdot(1), varR, varV, M10, M01, M20, M02 else - write (i + 30, '(6x,f12.6,8f24.8)') & - nondim_time, & - rho, & - vel(1), & - pres, & - alf, & - R(1), & - Rdot(1), & - nR(1), & - nRdot(1) + write (i + 30, '(6x,f12.6,8f24.8)') nondim_time, rho, vel(1), pres, alf, R(1), Rdot(1), nR(1), nRdot(1) ! ptilde, & ! ptot end if else if (bubbles_euler .and. (num_fluids == 3)) then - write (i + 30, '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,f24.8,'// & - 'f24.8,f24.8,f24.8,f24.8,f24.8, f24.8)') & - nondim_time, & - rho, & - vel(1), & - pres, & - alf, & - alfgr, & - nR(1), & - nRdot(1), & - R(1), & - Rdot(1), & - ptilde, & - ptot + write (i + 30, & + & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8, f24.8)') & + & nondim_time, rho, vel(1), pres, alf, alfgr, nR(1), nRdot(1), R(1), Rdot(1), ptilde, ptot else if (bubbles_euler .and. num_fluids == 4) then - write (i + 30, '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,'// & - 'f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8)') & - nondim_time, & - q_cons_vf(1)%sf(j - 2, 0, 0), & - q_cons_vf(2)%sf(j - 2, 0, 0), & - q_cons_vf(3)%sf(j - 2, 0, 0), & - q_cons_vf(4)%sf(j - 2, 0, 0), & - q_cons_vf(5)%sf(j - 2, 0, 0), & - q_cons_vf(6)%sf(j - 2, 0, 0), & - q_cons_vf(7)%sf(j - 2, 0, 0), & - q_cons_vf(8)%sf(j - 2, 0, 0), & - q_cons_vf(9)%sf(j - 2, 0, 0), & - q_cons_vf(10)%sf(j - 2, 0, 0), & - nbub, & - R(1), & - Rdot(1) + write (i + 30, & + & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8)') & + & nondim_time, q_cons_vf(1)%sf(j - 2, 0, 0), q_cons_vf(2)%sf(j - 2, 0, 0), q_cons_vf(3)%sf(j - 2, & + & 0, 0), q_cons_vf(4)%sf(j - 2, 0, 0), q_cons_vf(5)%sf(j - 2, 0, 0), q_cons_vf(6)%sf(j - 2, 0, 0), & + & q_cons_vf(7)%sf(j - 2, 0, 0), q_cons_vf(8)%sf(j - 2, 0, 0), q_cons_vf(9)%sf(j - 2, 0, 0), & + & q_cons_vf(10)%sf(j - 2, 0, 0), nbub, R(1), Rdot(1) else - write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8)') & - nondim_time, & - rho, & - vel(1), & - pres + write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8)') nondim_time, rho, vel(1), pres end if - elseif (p == 0) then + else if (p == 0) then if (bubbles_euler) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - write (i + 30, '(6X,10F24.8)') & - nondim_time, & - rho, & - vel(1), & - vel(2), & - pres, & - alf, & - nR(1), & - nRdot(1), & - R(1), & - Rdot(1) + write (i + 30, '(6X,10F24.8)') nondim_time, rho, vel(1), vel(2), pres, alf, nR(1), nRdot(1), R(1), & + & Rdot(1) #:endif else if (elasticity) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,'// & - 'F24.8,F24.8,F24.8)') & - nondim_time, & - rho, & - vel(1), & - vel(2), & - pres, & - tau_e(1), & - tau_e(2), & - tau_e(3) + write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,' // 'F24.8,F24.8,F24.8)') nondim_time, rho, & + & vel(1), vel(2), pres, tau_e(1), tau_e(2), tau_e(3) #:endif else - write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8)') & - nondim_time, & - rho, & - vel(1), & - pres + write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8)') nondim_time, rho, vel(1), pres print *, 'time =', nondim_time, 'rho =', rho, 'pres =', pres end if else #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,'// & - 'F24.8,F24.8,F24.8,F24.8,F24.8,'// & - 'F24.8)') & - nondim_time, & - rho, & - vel(1), & - vel(2), & - vel(3), & - pres, & - gamma, & - pi_inf, & - qv, & - c, & - accel + write (i + 30, & + & '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,' // 'F24.8,F24.8,F24.8,F24.8,F24.8,' // 'F24.8)') & + & nondim_time, rho, vel(1), vel(2), vel(3), pres, gamma, pi_inf, qv, c, accel #:endif end if end if @@ -1781,18 +1478,13 @@ contains if ((integral(i)%xmin <= x_cb(j)) .and. (integral(i)%xmax >= x_cb(j))) then npts = npts + 1 - call s_convert_to_mixture_variables(q_cons_vf, j, k, l, & - rho, gamma, pi_inf, qv, Re) + call s_convert_to_mixture_variables(q_cons_vf, j, k, l, rho, gamma, pi_inf, qv, Re) do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j, k, l)/rho end do - pres = ( & - (q_cons_vf(E_idx)%sf(j, k, l) - & - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, k, l)**2._wp)/rho)/ & - (1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - & - pi_inf - qv & - )/gamma + pres = ((q_cons_vf(E_idx)%sf(j, k, l) - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, k, & + & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma int_pres = int_pres + (pres - 1._wp)**2._wp end if end do @@ -1805,12 +1497,11 @@ contains if (proc_rank == 0) then if (bubbles_euler .and. (num_fluids <= 2)) then - write (i + 70, '(6x,f12.6,f24.8)') & - nondim_time, int_pres + write (i + 70, '(6x,f12.6,f24.8)') nondim_time, int_pres end if end if end do - elseif (p == 0) then + else if (p == 0) then if (num_integrals /= 3) then call s_mpi_abort('Incorrect number of integrals') end if @@ -1827,18 +1518,15 @@ contains do k = 1, n trigger = .false. if (i == 1) then - !inner portion - if (sqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) < (rad - 0.5_wp*thickness)) & - trigger = .true. - elseif (i == 2) then - !net region - if (sqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) > (rad - 0.5_wp*thickness) .and. & - sqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) < (rad + 0.5_wp*thickness)) & - trigger = .true. - elseif (i == 3) then - !everything else - if (sqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) > (rad + 0.5_wp*thickness)) & - trigger = .true. + ! inner portion + if (sqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) < (rad - 0.5_wp*thickness)) trigger = .true. + else if (i == 2) then + ! net region + if (sqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) > (rad - 0.5_wp*thickness) .and. sqrt(x_cb(j)**2._wp & + & + y_cb(k)**2._wp) < (rad + 0.5_wp*thickness)) trigger = .true. + else if (i == 3) then + ! everything else + if (sqrt(x_cb(j)**2._wp + y_cb(k)**2._wp) > (rad + 0.5_wp*thickness)) trigger = .true. end if pres = 0._wp @@ -1853,22 +1541,16 @@ contains if (trigger) then npts = npts + 1 - call s_convert_to_mixture_variables(q_cons_vf, j, k, l, & - rho, gamma, pi_inf, qv, Re) + call s_convert_to_mixture_variables(q_cons_vf, j, k, l, rho, gamma, pi_inf, qv, Re) do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j, k, l)/rho end do - pres = ( & - (q_cons_vf(E_idx)%sf(j, k, l) - & - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, k, l)**2._wp)/rho)/ & - (1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - & - pi_inf - qv & - )/gamma + pres = ((q_cons_vf(E_idx)%sf(j, k, l) - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, k, & + & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma int_pres = int_pres + abs(pres - 1._wp) max_pres = max(max_pres, abs(pres - 1._wp)) end if - end do end do @@ -1888,23 +1570,17 @@ contains if (proc_rank == 0) then if (bubbles_euler .and. (num_fluids <= 2)) then - write (i + 70, '(6x,f12.6,f24.8,f24.8)') & - nondim_time, int_pres, max_pres + write (i + 70, '(6x,f12.6,f24.8,f24.8)') nondim_time, int_pres, max_pres end if end if end do end if end if - end subroutine s_write_probe_files - - !> The goal of this subroutine is to write to the run-time - !! information file basic footer information applicable to - !! the current computation and to close the file when done. - !! The footer contains the stability criteria extrema over - !! all of the time-steps and the simulation run-time. + !> The goal of this subroutine is to write to the run-time information file basic footer information applicable to the current + !! computation and to close the file when done. The footer contains the stability criteria extrema over all of the time-steps + !! and the simulation run-time. impure subroutine s_close_run_time_information_file - real(wp) :: run_time !< Run-time of the simulation ! Writing the footer of and closing the run-time information file @@ -1921,41 +1597,28 @@ contains write (3, '(A,I0,A)') 'Run-time: ', int(anint(run_time)), 's' write (3, '(A)') ' ' close (3) - end subroutine s_close_run_time_information_file - !> Closes communication files impure subroutine s_close_com_files() - integer :: i !< Generic loop iterator do i = 1, num_fluids close (i + 120) end do - end subroutine s_close_com_files - !> Closes probe files impure subroutine s_close_probe_files - integer :: i !< Generic loop iterator do i = 1, num_probes close (i + 30) end do - end subroutine s_close_probe_files - impure subroutine s_close_ib_state_file - close (ib_state_unit) - end subroutine s_close_ib_state_file - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_data_output_module - integer :: i, m_ds, n_ds, p_ds ! Allocating/initializing ICFL, VCFL, CCFL and Rc stability criteria @@ -1986,12 +1649,9 @@ contains allocate (q_cons_temp_ds(i)%sf(-1:m_ds + 1, -1:n_ds + 1, -1:p_ds + 1)) end do end if - end subroutine s_initialize_data_output_module - !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_data_output_module - integer :: i if (probe_wrt) then @@ -2012,7 +1672,5 @@ contains end do deallocate (q_cons_temp_ds) end if - end subroutine s_finalize_data_output_module - end module m_data_output diff --git a/src/simulation/m_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index 53a8396cbf..3192e3990c 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -2,11 +2,11 @@ !! @file !! @brief Contains module m_derived_variables -!> @brief Derives diagnostic flow quantities (vorticity, speed of sound, numerical Schlieren, etc.) from conservative and primitive variables +!> @brief Derives diagnostic flow quantities (vorticity, speed of sound, numerical Schlieren, etc.) from conservative and primitive +!! variables #:include 'macros.fpp' module m_derived_variables - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code @@ -23,37 +23,30 @@ module m_derived_variables implicit none - private; public :: s_initialize_derived_variables_module, & - s_initialize_derived_variables, & - s_compute_derived_variables, & - s_finalize_derived_variables_module + private; public :: s_initialize_derived_variables_module, s_initialize_derived_variables, s_compute_derived_variables, & + & s_finalize_derived_variables_module - !> @name Finite-difference coefficients - !! 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. + !> @name Finite-difference coefficients 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), public, allocatable, dimension(:, :) :: fd_coeff_x - real(wp), public, allocatable, dimension(:, :) :: fd_coeff_y - real(wp), public, allocatable, dimension(:, :) :: fd_coeff_z + real(wp), public, allocatable, dimension(:,:) :: fd_coeff_x + real(wp), public, allocatable, dimension(:,:) :: fd_coeff_y + real(wp), public, allocatable, dimension(:,:) :: fd_coeff_z !> @} - $:GPU_DECLARE(create='[fd_coeff_x,fd_coeff_y,fd_coeff_z]') + $:GPU_DECLARE(create='[fd_coeff_x, fd_coeff_y, fd_coeff_z]') ! @name Variables for computing acceleration !> @{ - real(wp), public, allocatable, dimension(:, :, :) :: accel_mag - real(wp), public, allocatable, dimension(:, :, :) :: x_accel, y_accel, z_accel + real(wp), public, allocatable, dimension(:,:,:) :: accel_mag + real(wp), public, allocatable, dimension(:,:,:) :: x_accel, y_accel, z_accel !> @} - $:GPU_DECLARE(create='[accel_mag,x_accel,y_accel,z_accel]') - + $:GPU_DECLARE(create='[accel_mag, x_accel, y_accel, z_accel]') contains - !> Computation of parameters, allocation procedures, and/or - !! any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_derived_variables_module - ! Allocating the variables which will store the coefficients of the ! centered family of finite-difference schemes. Note that sufficient ! space is allocated so that the coefficients up to any chosen order @@ -81,12 +74,9 @@ contains end if end if end if - end subroutine s_initialize_derived_variables_module - !> Allocate and open derived variables. Computing FD coefficients. impure subroutine s_initialize_derived_variables - if (probe_wrt) then ! Opening and writing header of flow probe files if (proc_rank == 0) then @@ -94,68 +84,49 @@ contains call s_open_com_files() end if ! Computing centered finite difference coefficients - call s_compute_finite_difference_coefficients(m, x_cc, fd_coeff_x, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(m, x_cc, fd_coeff_x, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_x]') if (n > 0) then - call s_compute_finite_difference_coefficients(n, y_cc, fd_coeff_y, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(n, y_cc, fd_coeff_y, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_y]') end if if (p > 0) then - call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_z]') end if end if - end subroutine s_initialize_derived_variables - !> Writes coherent body information, communication files, and probes. - !! @param t_step Current time-step - !! @param q_cons_vf Conservative variables - !! @param q_prim_ts1 Primitive variables at time-stage 1 - !! @param q_prim_ts2 Primitive variables at time-stage 2 + !! @param t_step Current time-step + !! @param q_cons_vf Conservative variables + !! @param q_prim_ts1 Primitive variables at time-stage 1 + !! @param q_prim_ts2 Primitive variables at time-stage 2 subroutine s_compute_derived_variables(t_step, q_cons_vf, q_prim_ts1, q_prim_ts2) - - integer, intent(in) :: t_step + integer, intent(in) :: t_step type(scalar_field), dimension(:), intent(inout) :: q_cons_vf type(vector_field), dimension(:), intent(inout) :: q_prim_ts1, q_prim_ts2 - integer :: i, j, k !< Generic loop iterators + integer :: i, j, k !< Generic loop iterators if (probe_wrt) then - call s_derive_acceleration_component(1, q_prim_ts1(1)%vf, & - q_prim_ts1(2)%vf, & - q_prim_ts2(1)%vf, & - q_prim_ts2(2)%vf, & - x_accel) + call s_derive_acceleration_component(1, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, x_accel) if (n > 0) then - call s_derive_acceleration_component(2, q_prim_ts1(1)%vf, & - q_prim_ts1(2)%vf, & - q_prim_ts2(1)%vf, & - q_prim_ts2(2)%vf, & - y_accel) + call s_derive_acceleration_component(2, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, & + & y_accel) end if if (p > 0) then - call s_derive_acceleration_component(3, q_prim_ts1(1)%vf, & - q_prim_ts1(2)%vf, & - q_prim_ts2(1)%vf, & - q_prim_ts2(2)%vf, & - z_accel) + call s_derive_acceleration_component(3, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, & + & z_accel) end if - $:GPU_PARALLEL_LOOP(private='[i,j,k]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) do k = 0, p do j = 0, n do i = 0, m if (p > 0) then - accel_mag(i, j, k) = sqrt(x_accel(i, j, k)**2._wp + & - y_accel(i, j, k)**2._wp + & - z_accel(i, j, k)**2._wp) - elseif (n > 0) then - accel_mag(i, j, k) = sqrt(x_accel(i, j, k)**2._wp + & - y_accel(i, j, k)**2._wp) + accel_mag(i, j, k) = sqrt(x_accel(i, j, k)**2._wp + y_accel(i, j, k)**2._wp + z_accel(i, j, k)**2._wp) + else if (n > 0) then + accel_mag(i, j, k) = sqrt(x_accel(i, j, k)**2._wp + y_accel(i, j, k)**2._wp) else accel_mag(i, j, k) = x_accel(i, j, k) end if @@ -172,75 +143,60 @@ contains call s_write_com_files(t_step, c_mass) end if - end subroutine s_compute_derived_variables - - !> This subroutine receives as inputs the indicator of the - !! component of the acceleration that should be outputted and - !! the primitive variables. From those inputs, it proceeds - !! to calculate values of the desired acceleration component, - !! which are subsequently stored in derived flow quantity - !! storage variable, q_sf. - !! @param i Acceleration component indicator - !! @param q_prim_vf0 Primitive variables - !! @param q_prim_vf1 Primitive variables - !! @param q_prim_vf2 Primitive variables - !! @param q_prim_vf3 Primitive variables - !! @param q_sf Acceleration component - subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, & - q_prim_vf2, q_prim_vf3, q_sf) - - integer, intent(in) :: i - + !> This subroutine receives as inputs the indicator of the component of the acceleration that should be outputted and the + !! primitive variables. From those inputs, it proceeds to calculate values of the desired acceleration component, which are + !! subsequently stored in derived flow quantity storage variable, q_sf. + !! @param i Acceleration component indicator + !! @param q_prim_vf0 Primitive variables + !! @param q_prim_vf1 Primitive variables + !! @param q_prim_vf2 Primitive variables + !! @param q_prim_vf3 Primitive variables + !! @param q_sf Acceleration component + subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, q_prim_vf2, q_prim_vf3, q_sf) + integer, intent(in) :: i type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf0 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf1 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf2 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf3 - - real(wp), dimension(0:m, 0:n, 0:p), intent(out) :: q_sf - - integer :: j, k, l, r !< Generic loop iterators + real(wp), dimension(0:m, 0:n, 0:p), intent(out) :: q_sf + integer :: j, k, l, r !< Generic loop iterators ! Computing the acceleration component in the x-coordinate direction if (i == 1) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - q_sf(j, k, l) = (11._wp*q_prim_vf0(momxb)%sf(j, k, l) & - - 18._wp*q_prim_vf1(momxb)%sf(j, k, l) & - + 9._wp*q_prim_vf2(momxb)%sf(j, k, l) & - - 2._wp*q_prim_vf3(momxb)%sf(j, k, l))/(6._wp*dt) + q_sf(j, k, l) = (11._wp*q_prim_vf0(momxb)%sf(j, k, l) - 18._wp*q_prim_vf1(momxb)%sf(j, k, & + & l) + 9._wp*q_prim_vf2(momxb)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb)%sf(j, k, l))/(6._wp*dt) end do end do end do $:END_GPU_PARALLEL_LOOP() if (n == 0) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxb)%sf(r + j, k, l) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - elseif (p == 0) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + else if (p == 0) then + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxb)%sf(r + j, k, l) & - + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, k)* & - q_prim_vf0(momxb)%sf(j, r + k, l) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) end do end do end do @@ -248,36 +204,30 @@ contains $:END_GPU_PARALLEL_LOOP() else if (grid_geometry == 3) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxb)%sf(r + j, k, l) & - + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, k)* & - q_prim_vf0(momxb)%sf(j, r + k, l) & - + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, l)* & - q_prim_vf0(momxb)%sf(j, k, r + l)/y_cc(k) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxb)%sf(j, k, r + l)/y_cc(k) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxb)%sf(r + j, k, l) & - + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, k)* & - q_prim_vf0(momxb)%sf(j, r + k, l) & - + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, l)* & - q_prim_vf0(momxb)%sf(j, k, r + l) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxb)%sf(j, k, r + l) end do end do end do @@ -286,31 +236,27 @@ contains end if end if ! Computing the acceleration component in the y-coordinate direction - elseif (i == 2) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + else if (i == 2) then + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - q_sf(j, k, l) = (11._wp*q_prim_vf0(momxb + 1)%sf(j, k, l) & - - 18._wp*q_prim_vf1(momxb + 1)%sf(j, k, l) & - + 9._wp*q_prim_vf2(momxb + 1)%sf(j, k, l) & - - 2._wp*q_prim_vf3(momxb + 1)%sf(j, k, l))/(6._wp*dt) + q_sf(j, k, l) = (11._wp*q_prim_vf0(momxb + 1)%sf(j, k, l) - 18._wp*q_prim_vf1(momxb + 1)%sf(j, k, & + & l) + 9._wp*q_prim_vf2(momxb + 1)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb + 1)%sf(j, k, l))/(6._wp*dt) end do end do end do $:END_GPU_PARALLEL_LOOP() if (p == 0) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxb + 1)%sf(r + j, k, l) & - + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, k)* & - q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) end do end do end do @@ -318,37 +264,31 @@ contains $:END_GPU_PARALLEL_LOOP() else if (grid_geometry == 3) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxb + 1)%sf(r + j, k, l) & - + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, k)* & - q_prim_vf0(momxb + 1)%sf(j, r + k, l) & - + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, l)* & - q_prim_vf0(momxb + 1)%sf(j, k, r + l)/y_cc(k) & - - (q_prim_vf0(momxe)%sf(j, k, l)**2._wp)/y_cc(k) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & + & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & + & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, & + & r + l)/y_cc(k) - (q_prim_vf0(momxe)%sf(j, k, l)**2._wp)/y_cc(k) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxb + 1)%sf(r + j, k, l) & - + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, k)* & - q_prim_vf0(momxb + 1)%sf(j, r + k, l) & - + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, l)* & - q_prim_vf0(momxb + 1)%sf(j, k, r + l) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & + & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & + & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, r + l) end do end do end do @@ -358,52 +298,43 @@ contains end if ! Computing the acceleration component in the z-coordinate direction else - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - q_sf(j, k, l) = (11._wp*q_prim_vf0(momxe)%sf(j, k, l) & - - 18._wp*q_prim_vf1(momxe)%sf(j, k, l) & - + 9._wp*q_prim_vf2(momxe)%sf(j, k, l) & - - 2._wp*q_prim_vf3(momxe)%sf(j, k, l))/(6._wp*dt) + q_sf(j, k, l) = (11._wp*q_prim_vf0(momxe)%sf(j, k, l) - 18._wp*q_prim_vf1(momxe)%sf(j, k, & + & l) + 9._wp*q_prim_vf2(momxe)%sf(j, k, l) - 2._wp*q_prim_vf3(momxe)%sf(j, k, l))/(6._wp*dt) end do end do end do $:END_GPU_PARALLEL_LOOP() if (grid_geometry == 3) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxe)%sf(r + j, k, l) & - + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, k)* & - q_prim_vf0(momxe)%sf(j, r + k, l) & - + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, l)* & - q_prim_vf0(momxe)%sf(j, k, r + l)/y_cc(k) & - + (q_prim_vf0(momxe)%sf(j, k, l)* & - q_prim_vf0(momxb + 1)%sf(j, k, l))/y_cc(k) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxe)%sf(j, k, r + l)/y_cc(k) + (q_prim_vf0(momxe)%sf(j, k, & + & l)*q_prim_vf0(momxb + 1)%sf(j, k, l))/y_cc(k) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(private='[j,k,l,r]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, r]', collapse=4) do l = 0, p do k = 0, n do j = 0, m do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) & - + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, j)* & - q_prim_vf0(momxe)%sf(r + j, k, l) & - + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, k)* & - q_prim_vf0(momxe)%sf(j, r + k, l) & - + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, l)* & - q_prim_vf0(momxe)%sf(j, k, r + l) + q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & + & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxe)%sf(j, k, r + l) end do end do end do @@ -411,34 +342,30 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if - end subroutine s_derive_acceleration_component - - !> This subroutine is used together with the volume fraction - !! model and when called upon, it computes the location of - !! of the center of mass for each fluid from the inputted - !! primitive variables, q_prim_vf. The computed location - !! is then written to a formatted data file by the root process. - !! @param q_vf Primitive variables - !! @param c_m Mass,x-location,y-location,z-location + !> This subroutine is used together with the volume fraction model and when called upon, it computes the location of of the + !! center of mass for each fluid from the inputted primitive variables, q_prim_vf. The computed location is then written to a + !! formatted data file by the root process. + !! @param q_vf Primitive variables + !! @param c_m Mass,x-location,y-location,z-location impure subroutine s_derive_center_of_mass(q_vf, c_m) - type(scalar_field), dimension(sys_size), intent(IN) :: q_vf - real(wp), dimension(1:num_fluids, 1:5), intent(INOUT) :: c_m - integer :: i, j, k, l !< Generic loop iterators - real(wp) :: tmp, tmp_out !< Temporary variable to store quantity for mpi_allreduce - real(wp) :: dV !< Discrete cell volume + type(scalar_field), dimension(sys_size), intent(in) :: q_vf + real(wp), dimension(1:num_fluids, 1:5), intent(inout) :: c_m + integer :: i, j, k, l !< Generic loop iterators + real(wp) :: tmp, tmp_out !< Temporary variable to store quantity for mpi_allreduce + real(wp) :: dV !< Discrete cell volume - c_m(:, :) = 0.0_wp + c_m(:,:) = 0.0_wp $:GPU_UPDATE(device='[c_m]') - if (n == 0) then !1D simulation - $:GPU_PARALLEL_LOOP(collapse=3,private='[j,k,l,dV]') - do l = 0, p !Loop over grid + if (n == 0) then ! 1D simulation + $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, dV]') + do l = 0, p ! Loop over grid do k = 0, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids !Loop over individual fluids + do i = 1, num_fluids ! Loop over individual fluids dV = dx(j) ! Mass $:GPU_ATOMIC(atomic='update') @@ -454,13 +381,13 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - elseif (p == 0) then !2D simulation - $:GPU_PARALLEL_LOOP(collapse=3,private='[j,k,l,dV]') - do l = 0, p !Loop over grid + else if (p == 0) then ! 2D simulation + $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, dV]') + do l = 0, p ! Loop over grid do k = 0, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids !Loop over individual fluids + do i = 1, num_fluids ! Loop over individual fluids dV = dx(j)*dy(k) ! Mass $:GPU_ATOMIC(atomic='update') @@ -479,14 +406,13 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - else !3D simulation - $:GPU_PARALLEL_LOOP(collapse=3,private='[j,k,l,dV]') - do l = 0, p !Loop over grid + else ! 3D simulation + $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, dV]') + do l = 0, p ! Loop over grid do k = 0, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids !Loop over individual fluids - + do i = 1, num_fluids ! Loop over individual fluids dV = dx(j)*dy(k)*dz(l) ! Mass $:GPU_ATOMIC(atomic='update') @@ -512,8 +438,8 @@ contains $:GPU_UPDATE(host='[c_m]') - if (n == 0) then !1D simulation - do i = 1, num_fluids !Loop over individual fluids + if (n == 0) then ! 1D simulation + do i = 1, num_fluids ! Loop over individual fluids ! Sum all components across all processors using MPI_ALLREDUCE if (num_procs > 1) then tmp = c_m(i, 1) @@ -529,8 +455,8 @@ contains ! Compute quotients c_m(i, 2) = c_m(i, 2)/c_m(i, 1) end do - elseif (p == 0) then !2D simulation - do i = 1, num_fluids !Loop over individual fluids + else if (p == 0) then ! 2D simulation + do i = 1, num_fluids ! Loop over individual fluids ! Sum all components across all processors using MPI_ALLREDUCE if (num_procs > 1) then tmp = c_m(i, 1) @@ -550,8 +476,8 @@ contains c_m(i, 2) = c_m(i, 2)/c_m(i, 1) c_m(i, 3) = c_m(i, 3)/c_m(i, 1) end do - else !3D simulation - do i = 1, num_fluids !Loop over individual fluids + else ! 3D simulation + do i = 1, num_fluids ! Loop over individual fluids ! Sum all components across all processors using MPI_ALLREDUCE if (num_procs > 1) then tmp = c_m(i, 1) @@ -576,12 +502,9 @@ contains c_m(i, 4) = c_m(i, 4)/c_m(i, 1) end do end if - end subroutine s_derive_center_of_mass - !> Deallocation procedures for the module impure subroutine s_finalize_derived_variables_module - ! Closing CoM and flow probe files if (proc_rank == 0) then call s_close_com_files() @@ -605,7 +528,5 @@ contains 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) - end subroutine s_finalize_derived_variables_module - end module m_derived_variables diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 661767e13c..706a44b4c7 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -24,20 +24,16 @@ module m_fftw implicit none - private; public :: s_initialize_fftw_module, & - s_apply_fourier_filter, & - s_finalize_fftw_module + private; public :: s_initialize_fftw_module, s_apply_fourier_filter, s_finalize_fftw_module #if !defined(MFC_GPU) include 'fftw3.f03' #endif - type(c_ptr) :: fwd_plan, bwd_plan - type(c_ptr) :: fftw_real_data, fftw_cmplx_data, fftw_fltr_cmplx_data - integer :: real_size, cmplx_size, x_size, batch_size, Nfq - - real(c_double), pointer :: data_real(:) !< Real data - + type(c_ptr) :: fwd_plan, bwd_plan + type(c_ptr) :: fftw_real_data, fftw_cmplx_data, fftw_fltr_cmplx_data + integer :: real_size, cmplx_size, x_size, batch_size, Nfq + real(c_double), pointer :: data_real(:) !< Real data complex(c_double_complex), pointer :: data_cmplx(:) !< !! Complex data in Fourier space @@ -45,35 +41,31 @@ module m_fftw !! Filtered complex data in Fourier space #if defined(MFC_GPU) - $:GPU_DECLARE(create='[real_size,cmplx_size,x_size,batch_size,Nfq]') + $:GPU_DECLARE(create='[real_size, cmplx_size, x_size, batch_size, Nfq]') - real(dp), allocatable, target :: data_real_gpu(:) + real(dp), allocatable, target :: data_real_gpu(:) complex(dp), allocatable, target :: data_cmplx_gpu(:) complex(dp), allocatable, target :: data_fltr_cmplx_gpu(:) - $:GPU_DECLARE(create='[data_real_gpu,data_cmplx_gpu,data_fltr_cmplx_gpu]') + $:GPU_DECLARE(create='[data_real_gpu, data_cmplx_gpu, data_fltr_cmplx_gpu]') -!> @cond + !> @cond #if defined(__PGI) integer :: fwd_plan_gpu, bwd_plan_gpu #else -!> @endcond + !> @endcond type(c_ptr) :: fwd_plan_gpu, bwd_plan_gpu -!> @cond + !> @cond #endif -!> @endcond + !> @endcond integer, allocatable :: gpu_fft_size(:), iembed(:), oembed(:) - - integer :: istride, ostride, idist, odist, rank + integer :: istride, ostride, idist, odist, rank #endif - contains - !> The purpose of this subroutine is to create the fftw plan - !! that will be used in the forward and backward DFTs when - !! applying the Fourier filter in the azimuthal direction. + !> The purpose of this subroutine is to create the fftw plan that will be used in the forward and backward DFTs when applying + !! the Fourier filter in the azimuthal direction. impure subroutine s_initialize_fftw_module - integer :: ierr !< Generic flag used to identify and report GPU errors ! Size of input array going into DFT @@ -89,11 +81,11 @@ contains allocate (gpu_fft_size(1:rank), iembed(1:rank), oembed(1:rank)) - gpu_fft_size(1) = real_size; + gpu_fft_size(1) = real_size; iembed(1) = 0 oembed(1) = 0 - $:GPU_ENTER_DATA(copyin='[real_size,cmplx_size,x_size,sys_size,batch_size,Nfq]') - $:GPU_UPDATE(device='[real_size,cmplx_size,x_size,sys_size,batch_size]') + $:GPU_ENTER_DATA(copyin='[real_size, cmplx_size, x_size, sys_size, batch_size, Nfq]') + $:GPU_UPDATE(device='[real_size, cmplx_size, x_size, sys_size, batch_size]') #else ! Allocate input and output DFT data sizes fftw_real_data = fftw_alloc_real(int(real_size, c_size_t)) @@ -115,27 +107,25 @@ contains @:ALLOCATE(data_fltr_cmplx_gpu(1:cmplx_size*x_size*sys_size)) #if defined(__PGI) - ierr = cufftPlanMany(fwd_plan_gpu, rank, gpu_fft_size, iembed, istride, real_size, oembed, ostride, cmplx_size, CUFFT_D2Z, batch_size) - ierr = cufftPlanMany(bwd_plan_gpu, rank, gpu_fft_size, iembed, istride, cmplx_size, oembed, ostride, real_size, CUFFT_Z2D, batch_size) + ierr = cufftPlanMany(fwd_plan_gpu, rank, gpu_fft_size, iembed, istride, real_size, oembed, ostride, cmplx_size, & + & CUFFT_D2Z, batch_size) + ierr = cufftPlanMany(bwd_plan_gpu, rank, gpu_fft_size, iembed, istride, cmplx_size, oembed, ostride, real_size, & + & CUFFT_Z2D, batch_size) #else - ierr = hipfftPlanMany(fwd_plan_gpu, rank, gpu_fft_size, iembed, istride, real_size, oembed, ostride, cmplx_size, HIPFFT_D2Z, batch_size) - ierr = hipfftPlanMany(bwd_plan_gpu, rank, gpu_fft_size, iembed, istride, cmplx_size, oembed, ostride, real_size, HIPFFT_Z2D, batch_size) + ierr = hipfftPlanMany(fwd_plan_gpu, rank, gpu_fft_size, iembed, istride, real_size, oembed, ostride, cmplx_size, & + & HIPFFT_D2Z, batch_size) + ierr = hipfftPlanMany(bwd_plan_gpu, rank, gpu_fft_size, iembed, istride, cmplx_size, oembed, ostride, real_size, & + & HIPFFT_Z2D, batch_size) #endif - #endif - end subroutine s_initialize_fftw_module - - !> The purpose of this subroutine is to apply a Fourier low- - !! pass filter to the flow variables in the azimuthal direction - !! to remove the high-frequency content. This alleviates the - !! restrictive CFL condition arising from cells near the axis. + !> The purpose of this subroutine is to apply a Fourier low- pass filter to the flow variables in the azimuthal direction to + !! remove the high-frequency content. This alleviates the restrictive CFL condition arising from cells near the axis. !! @param q_cons_vf Conservative variables impure subroutine s_apply_fourier_filter(q_cons_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer :: i, j, k, l !< Generic loop iterators - integer :: ierr !< Generic flag used to identify and report GPU errors + integer :: i, j, k, l !< Generic loop iterators + integer :: ierr !< Generic flag used to identify and report GPU errors ! Restrict filter to processors that have cells adjacent to axis if (bc_y%beg >= 0) return @@ -176,7 +166,8 @@ contains do k = 1, sys_size do j = 0, m do l = 1, Nfq - data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) + data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1) & + & *cmplx_size*x_size) end do end do end do @@ -195,7 +186,8 @@ contains do k = 1, sys_size do j = 0, m do l = 0, p - data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size)/real(real_size, dp) + data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k - 1) & + & *real_size*x_size)/real(real_size, dp) q_cons_vf(k)%sf(j, 0, l) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) end do end do @@ -203,7 +195,6 @@ contains $:END_GPU_PARALLEL_LOOP() do i = 1, fourier_rings - $:GPU_PARALLEL_LOOP(collapse=3) do k = 1, sys_size do j = 0, m @@ -240,7 +231,8 @@ contains do k = 1, sys_size do j = 0, m do l = 1, Nfq - data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) + data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k & + & - 1)*cmplx_size*x_size) end do end do end do @@ -259,14 +251,14 @@ contains do k = 1, sys_size do j = 0, m do l = 0, p - data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size)/real(real_size, dp) + data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k & + & - 1)*real_size*x_size)/real(real_size, dp) q_cons_vf(k)%sf(j, i, l) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) end do end do end do $:END_GPU_PARALLEL_LOOP() end do - #else Nfq = 3 do j = 0, m @@ -297,14 +289,10 @@ contains end do end do #endif - end subroutine s_apply_fourier_filter - - !> The purpose of this subroutine is to destroy the fftw plan - !! that will be used in the forward and backward DFTs when - !! applying the Fourier filter in the azimuthal direction. + !> The purpose of this subroutine is to destroy the fftw plan that will be used in the forward and backward DFTs when applying + !! the Fourier filter in the azimuthal direction. impure subroutine s_finalize_fftw_module - #if defined(MFC_GPU) integer :: ierr !< Generic flag used to identify and report GPU errors @:DEALLOCATE(data_real_gpu, data_fltr_cmplx_gpu, data_cmplx_gpu) @@ -324,6 +312,5 @@ contains call fftw_destroy_plan(fwd_plan) call fftw_destroy_plan(bwd_plan) #endif - end subroutine s_finalize_fftw_module end module m_fftw diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index f1853095e4..675536af79 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -7,7 +7,6 @@ !> @brief Global parameters for the computational domain, fluid properties, and simulation algorithm configuration module m_global_parameters - #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -24,10 +23,10 @@ module m_global_parameters real(wp) :: wall_time_avg = 0 ! Logistics - integer :: num_procs !< Number of processors + integer :: num_procs !< Number of processors character(LEN=path_len) :: case_dir !< Case folder location - logical :: run_time_info !< Run-time output flag - integer :: t_step_old !< Existing IC/grid folder + logical :: run_time_info !< Run-time output flag + integer :: t_step_old !< Existing IC/grid folder ! Computational Domain Parameters integer :: proc_rank !< Rank of the local processor @@ -50,7 +49,7 @@ module m_global_parameters logical :: cyl_coord integer :: grid_geometry !> @} - $:GPU_DECLARE(create='[cyl_coord,grid_geometry]') + $:GPU_DECLARE(create='[cyl_coord, grid_geometry]') !> @name Cell-boundary (CB) locations in the x-, y- and z-directions, respectively !> @{ @@ -63,7 +62,7 @@ module m_global_parameters real(wp), target, allocatable, dimension(:) :: x_cc, y_cc, z_cc !> @} - !type(bounds_info) :: x_domain, y_domain, z_domain !< + ! type(bounds_info) :: x_domain, y_domain, z_domain !< !! Locations of the domain bounds in the x-, y- and z-coordinate directions !> @name Cell-width distributions in the x-, y- and z-directions, respectively !> @{ @@ -73,24 +72,22 @@ module m_global_parameters real(wp) :: dt !< Size of the time-step - $:GPU_DECLARE(create='[x_cb,y_cb,z_cb,x_cc,y_cc,z_cc,dx,dy,dz,dt,m,n,p]') + $:GPU_DECLARE(create='[x_cb, y_cb, z_cb, x_cc, y_cc, z_cc, dx, dy, dz, dt, m, n, p]') - !> @name Starting time-step iteration, stopping time-step iteration and the number - !! of time-step iterations between successive solution backups, respectively + !> @name Starting time-step iteration, stopping time-step iteration and the number of time-step iterations between successive + !! solution backups, respectively !> @{ integer :: t_step_start, t_step_stop, t_step_save !> @} - !> @name Starting time, stopping time, and time between backups, simulation time, - !! and prescribed cfl respectively + !> @name Starting time, stopping time, and time between backups, simulation time, and prescribed cfl respectively !> @{ real(wp) :: t_stop, t_save, cfl_target - integer :: n_start + integer :: n_start !> @} $:GPU_DECLARE(create='[cfl_target]') logical :: cfl_adap_dt, cfl_const_dt, cfl_dt - integer :: t_step_print !< Number of time-steps between printouts ! Simulation Algorithm Parameters @@ -112,42 +109,43 @@ module m_global_parameters integer, parameter :: muscl_polyn = ${muscl_polyn}$ !< Degree of the MUSCL polynomials (polyn) integer, parameter :: weno_order = ${weno_order}$ !< Order of the WENO reconstruction integer, parameter :: muscl_order = ${muscl_order}$ !< Order of the MUSCL order - integer, parameter :: weno_num_stencils = ${weno_num_stencils}$ !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) - integer, parameter :: muscl_lim = ${muscl_lim}$ !< MUSCL Limiter - integer, parameter :: num_fluids = ${num_fluids}$ !< number of fluids in the simulation - logical, parameter :: wenojs = (${wenojs}$ /= 0) !< WENO-JS (default) - logical, parameter :: mapped_weno = (${mapped_weno}$ /= 0) !< WENO-M (WENO with mapping of nonlinear weights) - logical, parameter :: wenoz = (${wenoz}$ /= 0) !< WENO-Z - logical, parameter :: teno = (${teno}$ /= 0) !< TENO (Targeted ENO) + integer, & + & parameter :: weno_num_stencils = ${weno_num_stencils}$ !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) + integer, parameter :: muscl_lim = ${muscl_lim}$ !< MUSCL Limiter + integer, parameter :: num_fluids = ${num_fluids}$ !< number of fluids in the simulation + logical, parameter :: wenojs = (${wenojs}$ /= 0) !< WENO-JS (default) + logical, parameter :: mapped_weno = (${mapped_weno}$ /= 0) !< WENO-M (WENO with mapping of nonlinear weights) + logical, parameter :: wenoz = (${wenoz}$ /= 0) !< WENO-Z + logical, parameter :: teno = (${teno}$ /= 0) !< TENO (Targeted ENO) real(wp), parameter :: wenoz_q = ${wenoz_q}$ !< Power constant for WENO-Z - logical, parameter :: mhd = (${mhd}$ /= 0) !< Magnetohydrodynamics - logical, parameter :: relativity = (${relativity}$ /= 0) !< Relativity (only for MHD) - integer, parameter :: igr_iter_solver = ${igr_iter_solver}$ !< IGR elliptic solver - integer, parameter :: igr_order = ${igr_order}$ !< Reconstruction order for IGR - logical, parameter :: igr = (${igr}$ /= 0) !< use information geometric regularization - logical, parameter :: igr_pres_lim = (${igr_pres_lim}$ /= 0)!< Limit to positive pressures for IGR - logical, parameter :: viscous = (${viscous}$ /= 0) !< Viscous effects + logical, parameter :: mhd = (${mhd}$ /= 0) !< Magnetohydrodynamics + logical, parameter :: relativity = (${relativity}$ /= 0) !< Relativity (only for MHD) + integer, parameter :: igr_iter_solver = ${igr_iter_solver}$ !< IGR elliptic solver + integer, parameter :: igr_order = ${igr_order}$ !< Reconstruction order for IGR + logical, parameter :: igr = (${igr}$ /= 0) !< use information geometric regularization + logical, parameter :: igr_pres_lim = (${igr_pres_lim}$ /= 0) !< Limit to positive pressures for IGR + logical, parameter :: viscous = (${viscous}$ /= 0) !< Viscous effects #:else - integer :: recon_type !< Reconstruction Type - integer :: weno_polyn !< Degree of the WENO polynomials (polyn) - integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn)i - integer :: weno_order !< Order of the WENO reconstruction - integer :: muscl_order !< Order of the MUSCL reconstruction - integer :: weno_num_stencils !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) - integer :: muscl_lim !< MUSCL Limiter - integer :: num_fluids !< number of fluids in the simulation - logical :: wenojs !< WENO-JS (default) - logical :: mapped_weno !< WENO-M (WENO with mapping of nonlinear weights) - logical :: wenoz !< WENO-Z - logical :: teno !< TENO (Targeted ENO) + integer :: recon_type !< Reconstruction Type + integer :: weno_polyn !< Degree of the WENO polynomials (polyn) + integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn)i + integer :: weno_order !< Order of the WENO reconstruction + integer :: muscl_order !< Order of the MUSCL reconstruction + integer :: weno_num_stencils !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) + integer :: muscl_lim !< MUSCL Limiter + integer :: num_fluids !< number of fluids in the simulation + logical :: wenojs !< WENO-JS (default) + logical :: mapped_weno !< WENO-M (WENO with mapping of nonlinear weights) + logical :: wenoz !< WENO-Z + logical :: teno !< TENO (Targeted ENO) real(wp) :: wenoz_q !< Power constant for WENO-Z - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity (only for MHD) - integer :: igr_iter_solver!< IGR elliptic solver - integer :: igr_order !< Reconstruction order for IGR - logical :: igr !< Use information geometric regularization - logical :: igr_pres_lim !< Limit to positive pressures for IGR - logical :: viscous !< Viscous effects + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity (only for MHD) + integer :: igr_iter_solver !< IGR elliptic solver + integer :: igr_order !< Reconstruction order for IGR + logical :: igr !< Use information geometric regularization + logical :: igr_pres_lim !< Limit to positive pressures for IGR + logical :: viscous !< Viscous effects #:endif !> @name Variables for our of core IGR computation on NVIDIA @@ -160,36 +158,35 @@ module m_global_parameters logical :: nv_uvm_pref_gpu ! Enable explicit gpu memory hints (default FALSE) !> @} - real(wp) :: weno_eps !< Binding for the WENO nonlinear weights - real(wp) :: teno_CT !< Smoothness threshold for TENO - logical :: mp_weno !< Monotonicity preserving (MP) WENO - logical :: weno_avg ! Average left/right cell-boundary states - logical :: weno_Re_flux !< WENO reconstruct velocity gradients for viscous stress tensor - integer :: riemann_solver !< Riemann solver algorithm - integer :: low_Mach !< Low Mach number fix to HLLC Riemann solver - integer :: wave_speeds !< Wave speeds estimation method - integer :: avg_state !< Average state evaluation method - logical :: alt_soundspeed !< Alternate mixture sound speed - logical :: null_weights !< Null undesired WENO weights - logical :: mixture_err !< Mixture properties correction - logical :: hypoelasticity !< hypoelasticity modeling - logical :: hyperelasticity !< hyperelasticity modeling - logical :: int_comp !< THINC interface compression - real(wp) :: ic_eps !< THINC Epsilon to compress on surface cells - real(wp) :: ic_beta !< THINC Sharpness Parameter - integer :: hyper_model !< hyperelasticity solver algorithm - logical :: elasticity !< elasticity modeling, true for hyper or hypo + real(wp) :: weno_eps !< Binding for the WENO nonlinear weights + real(wp) :: teno_CT !< Smoothness threshold for TENO + logical :: mp_weno !< Monotonicity preserving (MP) WENO + logical :: weno_avg ! Average left/right cell-boundary states + logical :: weno_Re_flux !< WENO reconstruct velocity gradients for viscous stress tensor + integer :: riemann_solver !< Riemann solver algorithm + integer :: low_Mach !< Low Mach number fix to HLLC Riemann solver + integer :: wave_speeds !< Wave speeds estimation method + integer :: avg_state !< Average state evaluation method + logical :: alt_soundspeed !< Alternate mixture sound speed + logical :: null_weights !< Null undesired WENO weights + logical :: mixture_err !< Mixture properties correction + logical :: hypoelasticity !< hypoelasticity modeling + logical :: hyperelasticity !< hyperelasticity modeling + logical :: int_comp !< THINC interface compression + real(wp) :: ic_eps !< THINC Epsilon to compress on surface cells + real(wp) :: ic_beta !< THINC Sharpness Parameter + integer :: hyper_model !< hyperelasticity solver algorithm + logical :: elasticity !< elasticity modeling, true for hyper or hypo logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling - logical :: shear_stress !< Shear stresses - logical :: bulk_stress !< Bulk stresses - logical :: cont_damage !< Continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD for divB=0 - integer :: num_igr_iters !< number of iterations for elliptic solve - integer :: num_igr_warm_start_iters !< number of warm start iterations for elliptic solve - real(wp) :: alf_factor !< alpha factor for IGR - - logical :: bodyForces - logical :: bf_x, bf_y, bf_z !< body force toggle in three directions + logical :: shear_stress !< Shear stresses + logical :: bulk_stress !< Bulk stresses + logical :: cont_damage !< Continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD for divB=0 + integer :: num_igr_iters !< number of iterations for elliptic solve + integer :: num_igr_warm_start_iters !< number of warm start iterations for elliptic solve + real(wp) :: alf_factor !< alpha factor for IGR + logical :: bodyForces + logical :: bf_x, bf_y, bf_z !< body force toggle in three directions !< amplitude, frequency, and phase shift sinusoid in each direction #:for dir in {'x', 'y', 'z'} #:for param in {'k','w','p','g'} @@ -203,24 +200,24 @@ module m_global_parameters integer :: cpu_start, cpu_end, cpu_rate #:if not MFC_CASE_OPTIMIZATION - $:GPU_DECLARE(create='[num_dims,num_vels,weno_polyn,weno_order]') - $:GPU_DECLARE(create='[weno_num_stencils,num_fluids,wenojs]') - $:GPU_DECLARE(create='[mapped_weno, wenoz,teno,wenoz_q,mhd,relativity]') - $:GPU_DECLARE(create='[igr_iter_solver,igr_order,viscous,igr_pres_lim,igr]') + $:GPU_DECLARE(create='[num_dims, num_vels, weno_polyn, weno_order]') + $:GPU_DECLARE(create='[weno_num_stencils, num_fluids, wenojs]') + $:GPU_DECLARE(create='[mapped_weno, wenoz, teno, wenoz_q, mhd, relativity]') + $:GPU_DECLARE(create='[igr_iter_solver, igr_order, viscous, igr_pres_lim, igr]') $:GPU_DECLARE(create='[recon_type, muscl_order, muscl_polyn, muscl_lim]') #:endif - $:GPU_DECLARE(create='[mpp_lim,model_eqns,mixture_err,alt_soundspeed]') - $:GPU_DECLARE(create='[avg_state,mp_weno,weno_eps,teno_CT,hypoelasticity]') - $:GPU_DECLARE(create='[hyperelasticity,hyper_model,elasticity,low_Mach]') - $:GPU_DECLARE(create='[shear_stress,bulk_stress,cont_damage,hyper_cleaning]') + $:GPU_DECLARE(create='[mpp_lim, model_eqns, mixture_err, alt_soundspeed]') + $:GPU_DECLARE(create='[avg_state, mp_weno, weno_eps, teno_CT, hypoelasticity]') + $:GPU_DECLARE(create='[hyperelasticity, hyper_model, elasticity, low_Mach]') + $:GPU_DECLARE(create='[shear_stress, bulk_stress, cont_damage, hyper_cleaning]') - logical :: relax !< activate phase change - integer :: relax_model !< Relaxation model + logical :: relax !< activate phase change + integer :: relax_model !< Relaxation model real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model - $:GPU_DECLARE(create='[relax, relax_model, palpha_eps,ptgalpha_eps]') + $:GPU_DECLARE(create='[relax, relax_model, palpha_eps, ptgalpha_eps]') integer :: num_bc_patches logical :: bc_io @@ -239,11 +236,10 @@ module m_global_parameters $:GPU_DECLARE(create='[x_domain, y_domain, z_domain]') real(wp) :: x_a, y_a, z_a real(wp) :: x_b, y_b, z_b - - logical :: parallel_io !< Format of the data files - logical :: file_per_process !< shared file or not when using parallel io - integer :: precision !< Precision of output files - logical :: down_sample !< down sample the output files + logical :: parallel_io !< Format of the data files + logical :: file_per_process !< shared file or not when using parallel io + integer :: precision !< Precision of output files + logical :: down_sample !< down sample the output files $:GPU_DECLARE(create='[down_sample]') integer, allocatable, dimension(:) :: proc_coords !< @@ -252,46 +248,46 @@ module m_global_parameters integer, allocatable, dimension(:) :: start_idx !< !! Starting cell-center index of local processor in global grid - type(mpi_io_var), public :: MPI_IO_DATA - type(mpi_io_ib_var), public :: MPI_IO_IB_DATA - type(mpi_io_airfoil_ib_var), public :: MPI_IO_airfoil_IB_DATA - type(mpi_io_levelset_var), public :: MPI_IO_levelset_DATA - type(mpi_io_levelset_norm_var), public :: MPI_IO_levelsetnorm_DATA - real(wp), allocatable, dimension(:, :), public :: MPI_IO_DATA_lag_bubbles + type(mpi_io_var), public :: MPI_IO_DATA + type(mpi_io_ib_var), public :: MPI_IO_IB_DATA + type(mpi_io_airfoil_ib_var), public :: MPI_IO_airfoil_IB_DATA + type(mpi_io_levelset_var), public :: MPI_IO_levelset_DATA + type(mpi_io_levelset_norm_var), public :: MPI_IO_levelsetnorm_DATA + real(wp), allocatable, dimension(:,:), public :: MPI_IO_DATA_lag_bubbles !> @name MPI info for parallel IO with Lustre file systems !> @{ character(LEN=name_len) :: mpiiofs - integer :: mpi_info_int + integer :: mpi_info_int !> @} - !> @name Annotations of the structure of the state and flux vectors in terms of the - !! size and the configuration of the system of equations to which they belong + !> @name Annotations of the structure of the state and flux vectors in terms of the size and the configuration of the system of + !! equations to which they belong !> @{ - integer :: sys_size !< Number of unknowns in system of eqns. + integer :: sys_size !< Number of unknowns in system of eqns. type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of energy equation - integer :: n_idx !< Index of number density + integer :: E_idx !< Index of energy equation + integer :: n_idx !< Index of number density type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: alf_idx !< Index of void fraction - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + integer :: alf_idx !< Index of void fraction + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. type(int_bounds_info) :: stress_idx !< Indexes of first and last shear stress eqns. type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: b_size !< Number of elements in the symmetric b tensor, plus one - integer :: tensor_size !< Number of elements in the full tensor plus one + integer :: b_size !< Number of elements in the symmetric b tensor, plus one + integer :: tensor_size !< Number of elements in the full tensor plus one type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: c_idx !< Index of color function - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + integer :: c_idx !< Index of color function + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD !> @} - $:GPU_DECLARE(create='[sys_size,E_idx,n_idx,bub_idx,alf_idx,gamma_idx]') - $:GPU_DECLARE(create='[pi_inf_idx,B_idx,stress_idx,xi_idx,b_size]') - $:GPU_DECLARE(create='[tensor_size,species_idx,c_idx]') + $:GPU_DECLARE(create='[sys_size, E_idx, n_idx, bub_idx, alf_idx, gamma_idx]') + $:GPU_DECLARE(create='[pi_inf_idx, B_idx, stress_idx, xi_idx, b_size]') + $:GPU_DECLARE(create='[tensor_size, species_idx, c_idx]') ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). ! Stands for "InDices With INTerior". @@ -304,16 +300,15 @@ module m_global_parameters type(int_bounds_info) :: idwbuff(1:3) $:GPU_DECLARE(create='[idwbuff]') - !> @name The number of fluids, along with their identifying indexes, respectively, - !! for which viscous effects, e.g. the shear and/or the volume Reynolds (Re) - !! numbers, will be non-negligible. + !> @name The number of fluids, along with their identifying indexes, respectively, for which viscous effects, e.g. the shear + !! and/or the volume Reynolds (Re) numbers, will be non-negligible. !> @{ - integer, dimension(2) :: Re_size - integer :: Re_size_max - integer, allocatable, dimension(:, :) :: Re_idx + integer, dimension(2) :: Re_size + integer :: Re_size_max + integer, allocatable, dimension(:,:) :: Re_idx !> @} - $:GPU_DECLARE(create='[Re_size,Re_size_max,Re_idx]') + $:GPU_DECLARE(create='[Re_size, Re_size_max, Re_idx]') ! The WENO average (WA) flag regulates whether the calculation of any cell- ! average spatial derivatives is carried out in each cell by utilizing the @@ -326,17 +321,16 @@ module m_global_parameters $:GPU_DECLARE(create='[wa_flg]') - !> @name The coordinate direction indexes and flags (flg), respectively, for which - !! the configurations will be determined with respect to a working direction - !! and that will be used to isolate the contributions, in that direction, in - !! the dimensionally split system of equations. + !> @name The coordinate direction indexes and flags (flg), respectively, for which the configurations will be determined with + !! respect to a working direction and that will be used to isolate the contributions, in that direction, in the dimensionally + !! split system of equations. !> @{ - integer, dimension(3) :: dir_idx + integer, dimension(3) :: dir_idx real(wp), dimension(3) :: dir_flg - integer, dimension(3) :: dir_idx_tau !!used for hypoelasticity=true + integer, dimension(3) :: dir_idx_tau !!used for hypoelasticity=true !> @} - $:GPU_DECLARE(create='[dir_idx,dir_flg,dir_idx_tau]') + $:GPU_DECLARE(create='[dir_idx, dir_flg, dir_idx_tau]') integer :: buff_size !< !! The number of cells that are necessary to be able to store enough boundary @@ -345,7 +339,7 @@ module m_global_parameters $:GPU_DECLARE(create='[buff_size]') - integer :: shear_num !! Number of shear stress components + integer :: shear_num !! Number of shear stress components integer, dimension(3) :: shear_indices !< !! Indices of the stress components that represent shear stress integer :: shear_BC_flip_num !< @@ -354,7 +348,7 @@ module m_global_parameters !! Indices of shear stress components to reflect for boundary conditions. !! Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, [indices]) - $:GPU_DECLARE(create='[shear_num,shear_indices,shear_BC_flip_num,shear_BC_flip_indices]') + $:GPU_DECLARE(create='[shear_num, shear_indices, shear_BC_flip_num, shear_BC_flip_indices]') ! END: Simulation Algorithm Parameters @@ -367,8 +361,7 @@ module m_global_parameters ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp - - integer :: fd_order !< + integer :: fd_order !< !! The order of the finite-difference (fd) approximations of the first-order !! derivatives that need to be evaluated when the CoM or flow probe data !! files are to be written at each time step @@ -377,36 +370,35 @@ module m_global_parameters !! The finite-difference number is given by MAX(1, fd_order/2). Essentially, !! it is a measure of the half-size of the finite-difference stencil for the !! selected order of accuracy. - $:GPU_DECLARE(create='[fd_order,fd_number]') + $:GPU_DECLARE(create='[fd_order, fd_number]') - logical :: probe_wrt - logical :: integral_wrt - integer :: num_probes - integer :: num_integrals - type(vec3_dt), dimension(num_probes_max) :: probe + logical :: probe_wrt + logical :: integral_wrt + integer :: num_probes + integer :: num_integrals + type(vec3_dt), dimension(num_probes_max) :: probe type(integral_parameters), dimension(num_probes_max) :: integral !> @name Reference density and pressure for Tait EOS !> @{ real(wp) :: rhoref, pref !> @} - $:GPU_DECLARE(create='[rhoref,pref]') + $:GPU_DECLARE(create='[rhoref, pref]') !> @name Immersed Boundaries !> @{ - logical :: ib - integer :: num_ibs - logical :: ib_state_wrt - + logical :: ib + integer :: num_ibs + logical :: ib_state_wrt type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib - type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l - integer :: Np + type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l + integer :: Np !! Database of the immersed boundary patch parameters for each of the !! patches employed in the configuration of the initial condition. Note that !! the maximum allowable number of patches, num_patches_max, may be changed !! in the module m_derived_types.f90. - $:GPU_DECLARE(create='[ib,num_ibs,patch_ib,Np,airfoil_grid_u,airfoil_grid_l]') + $:GPU_DECLARE(create='[ib, num_ibs, patch_ib, Np, airfoil_grid_u, airfoil_grid_l]') !> @} !> @name Bubble modeling @@ -421,47 +413,45 @@ module m_global_parameters real(wp) :: Ca !< Cavitation number real(wp) :: Web !< Weber number real(wp) :: Re_inv !< Inverse Reynolds number - $:GPU_DECLARE(create='[Eu,Ca,Web,Re_inv]') + $:GPU_DECLARE(create='[Eu, Ca, Web, Re_inv]') real(wp), dimension(:), allocatable :: weight !< Simpson quadrature weights real(wp), dimension(:), allocatable :: R0 !< Bubble sizes - $:GPU_DECLARE(create='[weight,R0]') + $:GPU_DECLARE(create='[weight, R0]') logical :: bubbles_euler !< Bubbles euler on/off logical :: polytropic !< Polytropic switch logical :: polydisperse !< Polydisperse bubbles - $:GPU_DECLARE(create='[bubbles_euler,polytropic,polydisperse]') + $:GPU_DECLARE(create='[bubbles_euler, polytropic, polydisperse]') - logical :: adv_n !< Solve the number density equation and compute alpha from number density - logical :: adap_dt !< Adaptive step size control + logical :: adv_n !< Solve the number density equation and compute alpha from number density + logical :: adap_dt !< Adaptive step size control real(wp) :: adap_dt_tol !< Tolerance to control adaptive step size - integer :: adap_dt_max_iters !< Maximum number of iterations - $:GPU_DECLARE(create='[adv_n,adap_dt,adap_dt_tol,adap_dt_max_iters]') + integer :: adap_dt_max_iters !< Maximum number of iterations + $:GPU_DECLARE(create='[adv_n, adap_dt, adap_dt_tol, adap_dt_max_iters]') integer :: bubble_model !< Gilmore or Keller--Miksis bubble model integer :: thermal !< Thermal behavior. 1 = adiabatic, 2 = isotherm, 3 = transfer - $:GPU_DECLARE(create='[bubble_model,thermal]') + $:GPU_DECLARE(create='[bubble_model, thermal]') - real(wp), allocatable, dimension(:, :, :) :: ptil !< Pressure modification - - real(wp) :: poly_sigma !< log normal sigma for polydisperse PDF + real(wp), allocatable, dimension(:,:,:) :: ptil !< Pressure modification + real(wp) :: poly_sigma !< log normal sigma for polydisperse PDF $:GPU_DECLARE(create='[ptil, poly_sigma]') - logical :: qbmm !< Quadrature moment method + logical :: qbmm !< Quadrature moment method integer, parameter :: nmom = 6 !< Number of carried moments per R0 location - integer :: nmomsp !< Number of moments required by ensemble-averaging - integer :: nmomtot !< Total number of carried moments moments/transport equations - - real(wp) :: pi_fac !< Factor for artificial pi_inf - $:GPU_DECLARE(create='[qbmm, nmomsp,nmomtot,pi_fac]') + integer :: nmomsp !< Number of moments required by ensemble-averaging + integer :: nmomtot !< Total number of carried moments moments/transport equations + real(wp) :: pi_fac !< Factor for artificial pi_inf + $:GPU_DECLARE(create='[qbmm, nmomsp, nmomtot, pi_fac]') #:if not MFC_CASE_OPTIMIZATION $:GPU_DECLARE(create='[nb]') #:endif - type(scalar_field), allocatable, dimension(:) :: mom_sp - type(scalar_field), allocatable, dimension(:, :, :) :: mom_3d - $:GPU_DECLARE(create='[mom_sp,mom_3d]') + type(scalar_field), allocatable, dimension(:) :: mom_sp + type(scalar_field), allocatable, dimension(:,:,:) :: mom_3d + $:GPU_DECLARE(create='[mom_sp, mom_3d]') !> @} @@ -471,36 +461,35 @@ module m_global_parameters !> @name Physical bubble parameters (see Ando 2010, Preston 2007) !> @{ real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl - $:GPU_DECLARE(create='[phi_vg,phi_gv,Pe_c,Tw,k_vl,k_gl]') + $:GPU_DECLARE(create='[phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl]') real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g real(wp), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN - $:GPU_DECLARE(create='[pb0,mass_g0,mass_v0,Pe_T,k_v,k_g]') - $:GPU_DECLARE(create='[Re_trans_T,Re_trans_c,Im_trans_T,Im_trans_c,omegaN]') + $:GPU_DECLARE(create='[pb0, mass_g0, mass_v0, Pe_T, k_v, k_g]') + $:GPU_DECLARE(create='[Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN]') real(wp) :: gam, gam_m - $:GPU_DECLARE(create='[gam,gam_m]') + $:GPU_DECLARE(create='[gam, gam_m]') - real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, & - gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g + real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g $:GPU_DECLARE(create='[R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, & - gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g]') + gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g]') !> @} !> @name Acoustic acoustic_source parameters !> @{ - logical :: acoustic_source !< Acoustic source switch + logical :: acoustic_source !< Acoustic source switch type(acoustic_parameters), dimension(num_probes_max) :: acoustic !< Acoustic source parameters - integer :: num_source !< Number of acoustic sources + integer :: num_source !< Number of acoustic sources !> @} - $:GPU_DECLARE(create='[acoustic_source,acoustic,num_source]') + $:GPU_DECLARE(create='[acoustic_source, acoustic, num_source]') !> @name Surface tension parameters !> @{ real(wp) :: sigma - logical :: surface_tension - $:GPU_DECLARE(create='[sigma,surface_tension]') + logical :: surface_tension + $:GPU_DECLARE(create='[sigma, surface_tension]') !> @} integer :: momxb, momxe @@ -511,30 +500,27 @@ module m_global_parameters integer :: strxb, strxe integer :: chemxb, chemxe integer :: xibeg, xiend - $:GPU_DECLARE(create='[momxb,momxe,advxb,advxe,contxb,contxe]') - $:GPU_DECLARE(create='[intxb,intxe, bubxb,bubxe]') - $:GPU_DECLARE(create='[strxb,strxe,chemxb,chemxe]') - $:GPU_DECLARE(create='[xibeg,xiend]') + $:GPU_DECLARE(create='[momxb, momxe, advxb, advxe, contxb, contxe]') + $:GPU_DECLARE(create='[intxb, intxe, bubxb, bubxe]') + $:GPU_DECLARE(create='[strxb, strxe, chemxb, chemxe]') + $:GPU_DECLARE(create='[xibeg, xiend]') real(wp), allocatable, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps - $:GPU_DECLARE(create='[gammas,gs_min,pi_infs,ps_inf,cvs,qvs,qvps]') - - real(wp) :: mytime !< Current simulation time - real(wp) :: finaltime !< Final simulation time - - logical :: rdma_mpi + $:GPU_DECLARE(create='[gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps]') + real(wp) :: mytime !< Current simulation time + real(wp) :: finaltime !< Final simulation time + logical :: rdma_mpi type(pres_field), allocatable, dimension(:) :: pb_ts - type(pres_field), allocatable, dimension(:) :: mv_ts - $:GPU_DECLARE(create='[pb_ts,mv_ts]') + $:GPU_DECLARE(create='[pb_ts, mv_ts]') !> @name lagrangian subgrid bubble parameters !> @{! - logical :: bubbles_lagrange !< Lagrangian subgrid bubble model switch + logical :: bubbles_lagrange !< Lagrangian subgrid bubble model switch type(bubbles_lagrange_parameters) :: lag_params !< Lagrange bubbles' parameters - $:GPU_DECLARE(create='[bubbles_lagrange,lag_params]') + $:GPU_DECLARE(create='[bubbles_lagrange, lag_params]') !> @} real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) @@ -548,7 +534,7 @@ module m_global_parameters real(wp) :: tau_star !< Stress threshold for continuum damage modeling real(wp) :: cont_damage_s !< Exponent s for continuum damage modeling real(wp) :: alpha_bar !< Damage rate factor for continuum damage modeling - $:GPU_DECLARE(create='[tau_star,cont_damage_s,alpha_bar]') + $:GPU_DECLARE(create='[tau_star, cont_damage_s, alpha_bar]') !> @} !> @name MHD Hyperbolic cleaning parameters @@ -557,14 +543,11 @@ module m_global_parameters real(wp) :: hyper_cleaning_tau !< Hyperbolic cleaning tau $:GPU_DECLARE(create='[hyper_cleaning_speed, hyper_cleaning_tau]') !> @} - contains - !> Assigns default values to the user inputs before reading - !! them in. This enables for an easier consistency check of - !! these parameters once they are read from the input file. + !> Assigns default values to the user inputs before reading them in. This enables for an easier consistency check of these + !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs - integer :: i, j !< Generic loop iterator ! Logistics @@ -702,8 +685,8 @@ contains bub_pp%gam_g = dflt_real; gam_g = dflt_real bub_pp%M_v = dflt_real; M_v = dflt_real bub_pp%M_g = dflt_real; M_g = dflt_real - bub_pp%k_v = dflt_real; - bub_pp%k_g = dflt_real; + bub_pp%k_v = dflt_real; + bub_pp%k_g = dflt_real; bub_pp%cp_v = dflt_real; cp_v = dflt_real bub_pp%cp_g = dflt_real; cp_g = dflt_real bub_pp%R_v = dflt_real; R_v = dflt_real @@ -898,14 +881,10 @@ contains patch_ib(i)%rotation_matrix(3, 3) = 1._wp patch_ib(i)%rotation_matrix_inverse = patch_ib(i)%rotation_matrix end do - end subroutine s_assign_default_values_to_user_inputs - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_global_parameters_module - integer :: i, j, k integer :: fac @@ -918,14 +897,14 @@ contains else weno_num_stencils = weno_polyn end if - elseif (recon_type == MUSCL_TYPE) then + else if (recon_type == MUSCL_TYPE) then muscl_polyn = muscl_order end if $:GPU_UPDATE(device='[weno_polyn, muscl_polyn]') $:GPU_UPDATE(device='[weno_num_stencils]') $:GPU_UPDATE(device='[nb]') - $:GPU_UPDATE(device='[num_dims,num_vels,num_fluids]') - $:GPU_UPDATE(device='[igr,igr_order,igr_iter_solver]') + $:GPU_UPDATE(device='[num_dims, num_vels, num_fluids]') + $:GPU_UPDATE(device='[igr, igr_order, igr_iter_solver]') #:endif ! Initializing the number of fluids for which viscous effects will @@ -938,7 +917,6 @@ contains ! Gamma/Pi_inf Model if (model_eqns == 1) then - ! Annotating structure of the state and flux vectors belonging ! to the system of equations defined by the selected number of ! spatial dimensions and the gamma/pi_inf model @@ -993,7 +971,7 @@ contains if (bubbles_euler) then bub_idx%beg = sys_size + 1 if (qbmm) then - nmomsp = 4 !number of special moments + nmomsp = 4 ! number of special moments if (nnode == 4) then ! nmom = 6 : It is already a parameter nmomtot = nmom*nb @@ -1027,7 +1005,6 @@ contains bub_idx%rs(i) = bub_idx%moms(i, 2) bub_idx%vs(i) = bub_idx%moms(i, 3) end do - else do i = 1, nb if (.not. polytropic) then @@ -1056,7 +1033,6 @@ contains end if sys_size = B_idx%end end if - else if (model_eqns == 3) then cont_idx%beg = 1 cont_idx%end = num_fluids @@ -1069,15 +1045,14 @@ contains internalEnergies_idx%beg = adv_idx%end + 1 internalEnergies_idx%end = adv_idx%end + num_fluids sys_size = internalEnergies_idx%end - else if (model_eqns == 4) then cont_idx%beg = 1 ! one continuity equation - cont_idx%end = 1 !num_fluids + cont_idx%end = 1 ! num_fluids mom_idx%beg = cont_idx%end + 1 ! one momentum equation in each direction mom_idx%end = cont_idx%end + num_vels E_idx = mom_idx%end + 1 ! one energy equation adv_idx%beg = E_idx + 1 - adv_idx%end = adv_idx%beg !one volume advection equation + adv_idx%end = adv_idx%beg ! one volume advection equation alf_idx = adv_idx%end sys_size = adv_idx%end @@ -1122,12 +1097,11 @@ contains Re_size_max = maxval(Re_size) - $:GPU_UPDATE(device='[Re_size,Re_size_max,shear_stress,bulk_stress]') + $:GPU_UPDATE(device='[Re_size, Re_size_max, shear_stress, bulk_stress]') ! Bookkeeping the indexes of any viscous fluids and any pairs of ! fluids whose interface will support effects of surface tension if (viscous) then - @:ALLOCATE(Re_idx(1:2, 1:Re_size_max)) k = 0 @@ -1143,13 +1117,10 @@ contains k = k + 1; Re_idx(2, k) = i end if end do - end if - end if if (model_eqns == 2 .or. model_eqns == 3) then - if (hypoelasticity .or. hyperelasticity) then elasticity = .true. stress_idx%beg = sys_size + 1 @@ -1178,7 +1149,7 @@ contains ! y-dir: flip tau_xy and tau_yz ! z-dir: flip tau_xz and tau_yz end if - $:GPU_UPDATE(device='[shear_num,shear_indices,shear_BC_flip_num,shear_BC_flip_indices]') + $:GPU_UPDATE(device='[shear_num, shear_indices, shear_BC_flip_num, shear_BC_flip_indices]') end if if (hyperelasticity) then @@ -1206,7 +1177,6 @@ contains psi_idx = sys_size + 1 sys_size = psi_idx end if - end if ! END: Volume Fraction Model @@ -1220,7 +1190,7 @@ contains if (bubbles_euler .and. qbmm .and. .not. polytropic) then allocate (MPI_IO_DATA%view(1:sys_size + 2*nb*nnode)) allocate (MPI_IO_DATA%var(1:sys_size + 2*nb*nnode)) - elseif (bubbles_lagrange) then + else if (bubbles_lagrange) then allocate (MPI_IO_DATA%view(1:sys_size + 1)) allocate (MPI_IO_DATA%var(1:sys_size + 1)) else @@ -1239,7 +1209,7 @@ contains allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) MPI_IO_DATA%var(i)%sf => null() end do - elseif (bubbles_lagrange) then + else if (bubbles_lagrange) then do i = 1, sys_size + 1 allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) MPI_IO_DATA%var(i)%sf => null() @@ -1274,26 +1244,20 @@ contains fd_number = max(1, fd_order/2) end if - call s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, & - igr_order, buff_size, & - idwint, idwbuff, viscous, & - bubbles_lagrange, m, n, p, & - num_dims, igr, ib) + call s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & + & bubbles_lagrange, m, n, p, num_dims, igr, ib) $:GPU_UPDATE(device='[idwint, idwbuff]') ! Configuring Coordinate Direction Indexes if (bubbles_euler) then - @:ALLOCATE(ptil(& - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(ptil( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end if $:GPU_UPDATE(device='[fd_order, fd_number]') if (cyl_coord .neqv. .true.) then ! Cartesian grid grid_geometry = 1 - elseif (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid + else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid grid_geometry = 2 else ! Fully 3D cylindrical grid grid_geometry = 3 @@ -1317,43 +1281,39 @@ contains chemxe = species_idx%end $:GPU_UPDATE(device='[momxb,momxe,advxb,advxe,contxb,contxe, & - & bubxb,bubxe,intxb,intxe,sys_size,buff_size,E_idx, & - & alf_idx,n_idx,adv_n,adap_dt,pi_fac,strxb,strxe, & - & chemxb,chemxe,c_idx,adap_dt_tol,adap_dt_max_iters]') - $:GPU_UPDATE(device='[b_size,xibeg,xiend,tensor_size]') + & bubxb, bubxe, intxb, intxe, sys_size, buff_size, E_idx, alf_idx, n_idx, adv_n, adap_dt, pi_fac, strxb, strxe, chemxb, & + & chemxe, c_idx, adap_dt_tol, adap_dt_max_iters]') + $:GPU_UPDATE(device='[b_size, xibeg, xiend, tensor_size]') $:GPU_UPDATE(device='[species_idx]') - $:GPU_UPDATE(device='[cfl_target,m,n,p]') + $:GPU_UPDATE(device='[cfl_target, m, n, p]') - $:GPU_UPDATE(device='[alt_soundspeed,acoustic_source,num_source]') + $:GPU_UPDATE(device='[alt_soundspeed, acoustic_source, num_source]') $:GPU_UPDATE(device='[dt,sys_size,buff_size,pref,rhoref, & - & gamma_idx,pi_inf_idx,E_idx,alf_idx,stress_idx, & - & mpp_lim,bubbles_euler,hypoelasticity,alt_soundspeed, & - & avg_state,model_eqns, & - & mixture_err,grid_geometry,cyl_coord,mp_weno,weno_eps, & - & teno_CT,hyperelasticity,hyper_model,elasticity,xi_idx, & - & B_idx,low_Mach]') + & gamma_idx, pi_inf_idx, E_idx, alf_idx, stress_idx, mpp_lim, bubbles_euler, hypoelasticity, alt_soundspeed, avg_state, & + & model_eqns, mixture_err, grid_geometry, cyl_coord, mp_weno, weno_eps, teno_CT, hyperelasticity, hyper_model, & + & elasticity, xi_idx, B_idx, low_Mach]') $:GPU_UPDATE(device='[Bx0]') $:GPU_UPDATE(device='[chem_params]') - $:GPU_UPDATE(device='[cont_damage,tau_star,cont_damage_s,alpha_bar]') + $:GPU_UPDATE(device='[cont_damage, tau_star, cont_damage_s, alpha_bar]') $:GPU_UPDATE(device='[hyper_cleaning, hyper_cleaning_speed, hyper_cleaning_tau]') #:if not MFC_CASE_OPTIMIZATION - $:GPU_UPDATE(device='[wenojs,mapped_weno,wenoz,teno]') + $:GPU_UPDATE(device='[wenojs, mapped_weno, wenoz, teno]') $:GPU_UPDATE(device='[wenoz_q]') $:GPU_UPDATE(device='[mhd, relativity]') $:GPU_UPDATE(device='[muscl_order, muscl_lim]') $:GPU_UPDATE(device='[igr, igr_order]') - $:GPU_UPDATE(device='[num_fluids,num_dims,viscous,num_vels,nb,muscl_lim]') + $:GPU_UPDATE(device='[num_fluids, num_dims, viscous, num_vels, nb, muscl_lim]') #:endif - $:GPU_UPDATE(device='[dir_idx,dir_flg,dir_idx_tau]') + $:GPU_UPDATE(device='[dir_idx, dir_flg, dir_idx_tau]') - $:GPU_UPDATE(device='[relax,relax_model,palpha_eps,ptgalpha_eps]') + $:GPU_UPDATE(device='[relax, relax_model, palpha_eps, ptgalpha_eps]') ! Allocating grid variables for the x-, y- and z-directions @:ALLOCATE(x_cb(-1 - buff_size:m + buff_size)) @@ -1363,7 +1323,7 @@ contains @:PREFER_GPU(x_cc) @:PREFER_GPU(dx) - if (n == 0) return; + if (n == 0) return; @:ALLOCATE(y_cb(-1 - buff_size:n + buff_size)) @:ALLOCATE(y_cc(-buff_size:n + buff_size)) @:ALLOCATE(dy(-buff_size:n + buff_size)) @@ -1371,19 +1331,16 @@ contains @:PREFER_GPU(y_cc) @:PREFER_GPU(dy) - if (p == 0) return; + if (p == 0) return; @:ALLOCATE(z_cb(-1 - buff_size:p + buff_size)) @:ALLOCATE(z_cc(-buff_size:p + buff_size)) @:ALLOCATE(dz(-buff_size:p + buff_size)) @:PREFER_GPU(z_cb) @:PREFER_GPU(z_cc) @:PREFER_GPU(dz) - end subroutine s_initialize_global_parameters_module - !> Initializes parallel infrastructure impure subroutine s_initialize_parallel_io - #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors #endif @@ -1417,14 +1374,10 @@ contains ! mpi_info_int = MPI_INFO_NULL allocate (start_idx(1:num_dims)) - #endif - end subroutine s_initialize_parallel_io - !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_global_parameters_module - integer :: i ! Deallocating the variables bookkeeping the indexes of any viscous @@ -1457,12 +1410,10 @@ contains ! Deallocating grid variables for the x-, y- and z-directions @:DEALLOCATE(x_cb, x_cc, dx) - if (n == 0) return; + if (n == 0) return; @:DEALLOCATE(y_cb, y_cc, dy) - if (p == 0) return; + if (p == 0) return; @:DEALLOCATE(z_cb, z_cc, dz) - end subroutine s_finalize_global_parameters_module - end module m_global_parameters diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index e687244280..b78f718b55 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -7,7 +7,6 @@ !> @brief Computes the left Cauchy--Green deformation tensor and hyperelastic stress source terms module m_hyperelastic - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -18,30 +17,24 @@ module m_hyperelastic implicit none - private; public :: s_hyperelastic_rmt_stress_update, & - s_initialize_hyperelastic_module, & - s_finalize_hyperelastic_module + private; public :: s_hyperelastic_rmt_stress_update, s_initialize_hyperelastic_module, s_finalize_hyperelastic_module !! The btensor at the cell-interior Gaussian quadrature points. !! These tensor is needed to be calculated once and make the code DRY. type(vector_field) :: btensor !< $:GPU_DECLARE(create='[btensor]') - real(wp), allocatable, dimension(:, :) :: fd_coeff_x_hyper - real(wp), allocatable, dimension(:, :) :: fd_coeff_y_hyper - real(wp), allocatable, dimension(:, :) :: fd_coeff_z_hyper - $:GPU_DECLARE(create='[fd_coeff_x_hyper,fd_coeff_y_hyper, fd_coeff_z_hyper]') + real(wp), allocatable, dimension(:,:) :: fd_coeff_x_hyper + real(wp), allocatable, dimension(:,:) :: fd_coeff_y_hyper + real(wp), allocatable, dimension(:,:) :: fd_coeff_z_hyper + $:GPU_DECLARE(create='[fd_coeff_x_hyper, fd_coeff_y_hyper, fd_coeff_z_hyper]') real(wp), allocatable, dimension(:) :: Gs_hyper $:GPU_DECLARE(create='[Gs_hyper]') - contains - !> The following subroutine handles the calculation of the btensor. - !! The calculation of the btensor takes qprimvf. - !! calculate the grad_xi, grad_xi is a nxn tensor - !! calculate the inverse of grad_xi to obtain F, F is a nxn tensor - !! calculate the FFtranspose to obtain the btensor, btensor is nxn tensor - !! btensor is symmetric, save the data space + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. calculate the + !! grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the FFtranspose to + !! obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space impure subroutine s_initialize_hyperelastic_module integer :: i !< generic iterator @@ -67,24 +60,18 @@ contains end if ! Computing centered finite difference coefficients - call s_compute_finite_difference_coefficients(m, x_cc, fd_coeff_x_hyper, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(m, x_cc, fd_coeff_x_hyper, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_x_hyper]') if (n > 0) then - call s_compute_finite_difference_coefficients(n, y_cc, fd_coeff_y_hyper, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(n, y_cc, fd_coeff_y_hyper, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_y_hyper]') end if if (p > 0) then - call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z_hyper, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z_hyper, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_z_hyper]') end if - end subroutine s_initialize_hyperelastic_module - - !> The following subroutine handles the calculation of the btensor. - !! The calculation of the btensor takes qprimvf. + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables !! calculate the grad_xi, grad_xi is a nxn tensor @@ -92,7 +79,6 @@ contains !! calculate the FFtranspose to obtain the btensor, btensor is nxn tensor !! btensor is symmetric, save the data space subroutine s_hyperelastic_rmt_stress_update(q_cons_vf, q_prim_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf #:if USING_AMD @@ -107,23 +93,22 @@ contains real(wp), dimension(num_fluids) :: alpha_k, alpha_rho_k #:endif real(wp), dimension(2) :: Re - real(wp) :: rho, gamma, pi_inf, qv - real(wp) :: G_local - integer :: j, k, l, i, r + real(wp) :: rho, gamma, pi_inf, qv + real(wp) :: G_local + integer :: j, k, l, i, r - $:GPU_PARALLEL_LOOP(collapse=3, private='[i,j,k,l,alpha_K, alpha_rho_K, rho, gamma, pi_inf, qv, G_local, Re, tensora, tensorb]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, alpha_K, alpha_rho_K, rho, gamma, pi_inf, qv, G_local, Re, tensora, tensorb]') do l = 0, p do k = 0, n do j = 0, m - call s_compute_species_fraction(q_cons_vf, j, k, l, alpha_rho_k, alpha_k) ! If in simulation, use acc mixture subroutines - call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, alpha_k, & - alpha_rho_k, Re, G_local, Gs_hyper) + call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, alpha_k, alpha_rho_k, Re, G_local, & + & Gs_hyper) rho = max(rho, sgm_eps) G_local = max(G_local, sgm_eps) - !if ( G_local <= verysmall ) G_K = 0._wp + ! if ( G_local <= verysmall ) G_K = 0._wp if (G_local > verysmall) then $:GPU_LOOP(parallelism='[seq]') @@ -162,9 +147,8 @@ contains tensorb(9) = tensora(1)*tensora(5) - tensora(2)*tensora(4) ! STEP 2b: computing the determinant of the grad_xi tensor - tensorb(tensor_size) = tensora(1)*(tensora(5)*tensora(9) - tensora(6)*tensora(8)) & - - tensora(2)*(tensora(4)*tensora(9) - tensora(6)*tensora(7)) & - + tensora(3)*(tensora(4)*tensora(8) - tensora(5)*tensora(7)) + tensorb(tensor_size) = tensora(1)*(tensora(5)*tensora(9) - tensora(6)*tensora(8)) - tensora(2)*(tensora(4) & + & *tensora(9) - tensora(6)*tensora(7)) + tensora(3)*(tensora(4)*tensora(8) - tensora(5)*tensora(7)) if (tensorb(tensor_size) > verysmall) then ! STEP 2c: computing the inverse of grad_xi tensor = F @@ -193,17 +177,16 @@ contains ! STEP 5a: updating the Cauchy stress primitive scalar field if (hyper_model == 1) then call s_neoHookean_cauchy_solver(btensor%vf, q_prim_vf, G_local, j, k, l) - elseif (hyper_model == 2) then + else if (hyper_model == 2) then call s_Mooney_Rivlin_cauchy_solver(btensor%vf, q_prim_vf, G_local, j, k, l) end if ! STEP 5b: updating the pressure field - q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, l) - & - G_local*q_prim_vf(xiend + 1)%sf(j, k, l)/gamma + q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, l) - G_local*q_prim_vf(xiend + 1)%sf(j, k, & + & l)/gamma ! STEP 5c: updating the Cauchy stress conservative scalar field $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size - 1 - q_cons_vf(strxb + i - 1)%sf(j, k, l) = & - rho*q_prim_vf(strxb + i - 1)%sf(j, k, l) + q_cons_vf(strxb + i - 1)%sf(j, k, l) = rho*q_prim_vf(strxb + i - 1)%sf(j, k, l) end do end if end if @@ -212,9 +195,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_hyperelastic_rmt_stress_update - - !> The following subroutine handles the calculation of the btensor. - !! The calculation of the btensor takes qprimvf. + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. !! @param btensor_in Left Cauchy-Green deformation tensor !! @param q_prim_vf Primitive variables !! @param G_param Elastic shear modulus @@ -228,13 +209,12 @@ contains subroutine s_neoHookean_cauchy_solver(btensor_in, q_prim_vf, G_param, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - type(scalar_field), dimension(b_size), intent(inout) :: btensor_in - real(wp), intent(in) :: G_param - integer, intent(in) :: j, k, l - - real(wp) :: trace - real(wp), parameter :: f13 = 1._wp/3._wp - integer :: i !< Generic loop iterators + type(scalar_field), dimension(b_size), intent(inout) :: btensor_in + real(wp), intent(in) :: G_param + integer, intent(in) :: j, k, l + real(wp) :: trace + real(wp), parameter :: f13 = 1._wp/3._wp + integer :: i !< Generic loop iterators ! tensor is the symmetric tensor & calculate the trace of the tensor trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) @@ -247,17 +227,12 @@ contains ! setting the tensor to the stresses for riemann solver $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size - 1 - q_prim_vf(strxb + i - 1)%sf(j, k, l) = & - G_param*btensor_in(i)%sf(j, k, l)/btensor_in(b_size)%sf(j, k, l) + q_prim_vf(strxb + i - 1)%sf(j, k, l) = G_param*btensor_in(i)%sf(j, k, l)/btensor_in(b_size)%sf(j, k, l) end do ! compute the invariant without the elastic modulus - q_prim_vf(xiend + 1)%sf(j, k, l) = & - 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) - + q_prim_vf(xiend + 1)%sf(j, k, l) = 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) end subroutine s_neoHookean_cauchy_solver - - !> The following subroutine handles the calculation of the btensor. - !! The calculation of the btensor takes qprimvf. + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. !! @param btensor_in Left Cauchy-Green deformation tensor !! @param q_prim_vf Primitive variables !! @param G_param Elastic shear modulus @@ -271,15 +246,14 @@ contains subroutine s_Mooney_Rivlin_cauchy_solver(btensor_in, q_prim_vf, G_param, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - type(scalar_field), dimension(b_size), intent(inout) :: btensor_in - real(wp), intent(in) :: G_param - integer, intent(in) :: j, k, l - - real(wp) :: trace - real(wp), parameter :: f13 = 1._wp/3._wp - integer :: i !< Generic loop iterators - - !TODO Make this 1D and 2D capable + type(scalar_field), dimension(b_size), intent(inout) :: btensor_in + real(wp), intent(in) :: G_param + integer, intent(in) :: j, k, l + real(wp) :: trace + real(wp), parameter :: f13 = 1._wp/3._wp + integer :: i !< Generic loop iterators + + ! TODO Make this 1D and 2D capable ! tensor is the symmetric tensor & calculate the trace of the tensor trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) @@ -292,18 +266,13 @@ contains ! setting the tensor to the stresses for riemann solver $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size - 1 - q_prim_vf(strxb + i - 1)%sf(j, k, l) = & - G_param*btensor_in(i)%sf(j, k, l)/btensor_in(b_size)%sf(j, k, l) + q_prim_vf(strxb + i - 1)%sf(j, k, l) = G_param*btensor_in(i)%sf(j, k, l)/btensor_in(b_size)%sf(j, k, l) end do ! compute the invariant without the elastic modulus - q_prim_vf(xiend + 1)%sf(j, k, l) = & - 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) - + q_prim_vf(xiend + 1)%sf(j, k, l) = 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) end subroutine s_Mooney_Rivlin_cauchy_solver - !> @brief Deallocates memory for hyperelastic deformation tensor and finite-difference coefficients. impure subroutine s_finalize_hyperelastic_module() - integer :: i !< iterator ! Deallocating memory @@ -317,7 +286,5 @@ contains @:DEALLOCATE(fd_coeff_z_hyper) end if end if - end subroutine s_finalize_hyperelastic_module - end module m_hyperelastic diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index 8ee46b1ba8..957f977f6b 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -6,7 +6,6 @@ !> @brief Computes hypoelastic stress-rate source terms and damage-state evolution module m_hypoelastic - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_finite_differences @@ -14,32 +13,28 @@ module m_hypoelastic implicit none - private; public :: s_initialize_hypoelastic_module, & - s_finalize_hypoelastic_module, & - s_compute_hypoelastic_rhs, & - s_compute_damage_state + private; public :: s_initialize_hypoelastic_module, s_finalize_hypoelastic_module, s_compute_hypoelastic_rhs, & + & s_compute_damage_state real(wp), allocatable, dimension(:) :: Gs_hypo $:GPU_DECLARE(create='[Gs_hypo]') - real(wp), allocatable, dimension(:, :, :) :: du_dx_hypo, du_dy_hypo, du_dz_hypo - real(wp), allocatable, dimension(:, :, :) :: dv_dx_hypo, dv_dy_hypo, dv_dz_hypo - real(wp), allocatable, dimension(:, :, :) :: dw_dx_hypo, dw_dy_hypo, dw_dz_hypo - $:GPU_DECLARE(create='[du_dx_hypo,du_dy_hypo,du_dz_hypo,dv_dx_hypo,dv_dy_hypo,dv_dz_hypo,dw_dx_hypo,dw_dy_hypo,dw_dz_hypo]') - - real(wp), allocatable, dimension(:, :, :) :: rho_K_field, G_K_field - $:GPU_DECLARE(create='[rho_K_field,G_K_field]') + real(wp), allocatable, dimension(:,:,:) :: du_dx_hypo, du_dy_hypo, du_dz_hypo + real(wp), allocatable, dimension(:,:,:) :: dv_dx_hypo, dv_dy_hypo, dv_dz_hypo + real(wp), allocatable, dimension(:,:,:) :: dw_dx_hypo, dw_dy_hypo, dw_dz_hypo + $:GPU_DECLARE(create='[du_dx_hypo, du_dy_hypo, du_dz_hypo, dv_dx_hypo, dv_dy_hypo, dv_dz_hypo, dw_dx_hypo, dw_dy_hypo, dw_dz_hypo]') - real(wp), allocatable, dimension(:, :) :: fd_coeff_x_hypo - real(wp), allocatable, dimension(:, :) :: fd_coeff_y_hypo - real(wp), allocatable, dimension(:, :) :: fd_coeff_z_hypo - $:GPU_DECLARE(create='[fd_coeff_x_hypo,fd_coeff_y_hypo,fd_coeff_z_hypo]') + real(wp), allocatable, dimension(:,:,:) :: rho_K_field, G_K_field + $:GPU_DECLARE(create='[rho_K_field, G_K_field]') + real(wp), allocatable, dimension(:,:) :: fd_coeff_x_hypo + real(wp), allocatable, dimension(:,:) :: fd_coeff_y_hypo + real(wp), allocatable, dimension(:,:) :: fd_coeff_z_hypo + $:GPU_DECLARE(create='[fd_coeff_x_hypo, fd_coeff_y_hypo, fd_coeff_z_hypo]') contains !> @brief Allocates arrays and computes finite-difference coefficients for the hypoelastic stress model. impure subroutine s_initialize_hypoelastic_module - integer :: i @:ALLOCATE(Gs_hypo(1:num_fluids)) @@ -67,37 +62,28 @@ contains end if ! Computing centered finite difference coefficients - call s_compute_finite_difference_coefficients(m, x_cc, fd_coeff_x_hypo, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(m, x_cc, fd_coeff_x_hypo, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_x_hypo]') if (n > 0) then - call s_compute_finite_difference_coefficients(n, y_cc, fd_coeff_y_hypo, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(n, y_cc, fd_coeff_y_hypo, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_y_hypo]') end if if (p > 0) then - call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z_hypo, buff_size, & - fd_number, fd_order) + call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z_hypo, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_z_hypo]') end if - end subroutine s_initialize_hypoelastic_module - - !> The purpose of this procedure is to compute the source terms - !! that are needed for the elastic stress equations - !! @param idir Dimension splitting index - !! @param q_prim_vf Primitive variables - !! @param rhs_vf rhs variables + !> The purpose of this procedure is to compute the source terms that are needed for the elastic stress equations + !! @param idir Dimension splitting index + !! @param q_prim_vf Primitive variables + !! @param rhs_vf rhs variables subroutine s_compute_hypoelastic_rhs(idir, q_prim_vf, rhs_vf) - - integer, intent(in) :: idir - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + integer, intent(in) :: idir + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - - real(wp) :: rho_K, G_K - - integer :: i, k, l, q, r !< Loop variables - integer :: ndirs !< Number of coordinate directions + real(wp) :: rho_K, G_K + integer :: i, k, l, q, r !< Loop variables + integer :: ndirs !< Number of coordinate directions ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 @@ -121,10 +107,8 @@ contains do k = 0, m $:GPU_LOOP(parallelism='[seq]') do r = -fd_number, fd_number - du_dx_hypo(k, l, q) = du_dx_hypo(k, l, q) & - + q_prim_vf(momxb)%sf(k + r, l, q)*fd_coeff_x_hypo(r, k) + du_dx_hypo(k, l, q) = du_dx_hypo(k, l, q) + q_prim_vf(momxb)%sf(k + r, l, q)*fd_coeff_x_hypo(r, k) end do - end do end do end do @@ -147,12 +131,11 @@ contains do k = 0, m $:GPU_LOOP(parallelism='[seq]') do r = -fd_number, fd_number - du_dy_hypo(k, l, q) = du_dy_hypo(k, l, q) & - + q_prim_vf(momxb)%sf(k, l + r, q)*fd_coeff_y_hypo(r, l) - dv_dx_hypo(k, l, q) = dv_dx_hypo(k, l, q) & - + q_prim_vf(momxb + 1)%sf(k + r, l, q)*fd_coeff_x_hypo(r, k) - dv_dy_hypo(k, l, q) = dv_dy_hypo(k, l, q) & - + q_prim_vf(momxb + 1)%sf(k, l + r, q)*fd_coeff_y_hypo(r, l) + du_dy_hypo(k, l, q) = du_dy_hypo(k, l, q) + q_prim_vf(momxb)%sf(k, l + r, q)*fd_coeff_y_hypo(r, l) + dv_dx_hypo(k, l, q) = dv_dx_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k + r, l, & + & q)*fd_coeff_x_hypo(r, k) + dv_dy_hypo(k, l, q) = dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l + r, & + & q)*fd_coeff_y_hypo(r, l) end do end do end do @@ -161,13 +144,12 @@ contains ! 3D if (ndirs == 3) then - $:GPU_PARALLEL_LOOP(collapse=3) do q = 0, p do l = 0, n do k = 0, m - du_dz_hypo(k, l, q) = 0._wp; dv_dz_hypo(k, l, q) = 0._wp; dw_dx_hypo(k, l, q) = 0._wp; - dw_dy_hypo(k, l, q) = 0._wp; dw_dz_hypo(k, l, q) = 0._wp; + du_dz_hypo(k, l, q) = 0._wp; dv_dz_hypo(k, l, q) = 0._wp; dw_dx_hypo(k, l, q) = 0._wp; + dw_dy_hypo(k, l, q) = 0._wp; dw_dz_hypo(k, l, q) = 0._wp; end do end do end do @@ -179,16 +161,16 @@ contains do k = 0, m $:GPU_LOOP(parallelism='[seq]') do r = -fd_number, fd_number - du_dz_hypo(k, l, q) = du_dz_hypo(k, l, q) & - + q_prim_vf(momxb)%sf(k, l, q + r)*fd_coeff_z_hypo(r, q) - dv_dz_hypo(k, l, q) = dv_dz_hypo(k, l, q) & - + q_prim_vf(momxb + 1)%sf(k, l, q + r)*fd_coeff_z_hypo(r, q) - dw_dx_hypo(k, l, q) = dw_dx_hypo(k, l, q) & - + q_prim_vf(momxe)%sf(k + r, l, q)*fd_coeff_x_hypo(r, k) - dw_dy_hypo(k, l, q) = dw_dy_hypo(k, l, q) & - + q_prim_vf(momxe)%sf(k, l + r, q)*fd_coeff_y_hypo(r, l) - dw_dz_hypo(k, l, q) = dw_dz_hypo(k, l, q) & - + q_prim_vf(momxe)%sf(k, l, q + r)*fd_coeff_z_hypo(r, q) + du_dz_hypo(k, l, q) = du_dz_hypo(k, l, q) + q_prim_vf(momxb)%sf(k, l, & + & q + r)*fd_coeff_z_hypo(r, q) + dv_dz_hypo(k, l, q) = dv_dz_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, & + & q + r)*fd_coeff_z_hypo(r, q) + dw_dx_hypo(k, l, q) = dw_dx_hypo(k, l, q) + q_prim_vf(momxe)%sf(k + r, l, & + & q)*fd_coeff_x_hypo(r, k) + dw_dy_hypo(k, l, q) = dw_dy_hypo(k, l, q) + q_prim_vf(momxe)%sf(k, l + r, & + & q)*fd_coeff_y_hypo(r, l) + dw_dz_hypo(k, l, q) = dw_dz_hypo(k, l, q) + q_prim_vf(momxe)%sf(k, l, & + & q + r)*fd_coeff_z_hypo(r, q) end do end do end do @@ -203,8 +185,8 @@ contains do k = 0, m rho_K = 0._wp; G_K = 0._wp do i = 1, num_fluids - rho_K = rho_K + q_prim_vf(i)%sf(k, l, q) !alpha_rho_K(1) - G_K = G_K + q_prim_vf(advxb - 1 + i)%sf(k, l, q)*Gs_hypo(i) !alpha_K(1) * Gs_hypo(1) + rho_K = rho_K + q_prim_vf(i)%sf(k, l, q) ! alpha_rho_K(1) + G_K = G_K + q_prim_vf(advxb - 1 + i)%sf(k, l, q)*Gs_hypo(i) ! alpha_K(1) * Gs_hypo(1) end do if (cont_damage) G_K = G_K*max((1._wp - q_prim_vf(damage_idx)%sf(k, l, q)), 0._wp) @@ -212,7 +194,7 @@ contains rho_K_field(k, l, q) = rho_K G_K_field(k, l, q) = G_K - !TODO: take this out if not needed + ! TODO: take this out if not needed if (G_K < verysmall) then G_K_field(k, l, q) = 0 end if @@ -226,114 +208,85 @@ contains do q = 0, p do l = 0, n do k = 0, m - rhs_vf(strxb)%sf(k, l, q) = & - rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)* & - ((4._wp*G_K_field(k, l, q)/3._wp) + & - q_prim_vf(strxb)%sf(k, l, q))* & - du_dx_hypo(k, l, q) + rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*((4._wp*G_K_field(k, l, & + & q)/3._wp) + q_prim_vf(strxb)%sf(k, l, q))*du_dx_hypo(k, l, q) end do end do end do $:END_GPU_PARALLEL_LOOP() - - elseif (idir == 2) then + else if (idir == 2) then $:GPU_PARALLEL_LOOP(collapse=3) do q = 0, p do l = 0, n do k = 0, m - rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy_hypo(k, l, q) + & - q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy_hypo(k, l, q) - & - q_prim_vf(strxb)%sf(k, l, q)*dv_dy_hypo(k, l, q) - & - 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dv_dy_hypo(k, l, q)) - - rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, q) + & - q_prim_vf(strxb)%sf(k, l, q)*dv_dx_hypo(k, l, q) - & - q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, q) + & - q_prim_vf(strxb + 2)%sf(k, l, q)*du_dy_hypo(k, l, q) + & - q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy_hypo(k, l, q) - & - q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy_hypo(k, l, q) + & - 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dy_hypo(k, l, q) + & - dv_dx_hypo(k, l, q))) - - rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx_hypo(k, l, q) + & - q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx_hypo(k, l, q) - & - q_prim_vf(strxb + 2)%sf(k, l, q)*du_dx_hypo(k, l, q) + & - q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + & - q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) - & - q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + & - 2._wp*G_K_field(k, l, q)*(dv_dy_hypo(k, l, q) - (1._wp/3._wp)* & - (du_dx_hypo(k, l, q) + & - dv_dy_hypo(k, l, q)))) + rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxb + 1)%sf(k, & + & l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy_hypo(k, l, & + & q) - q_prim_vf(strxb)%sf(k, l, q)*dv_dy_hypo(k, l, q) - 2._wp*G_K_field(k, l, & + & q)*(1._wp/3._wp)*dv_dy_hypo(k, l, q)) + + rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, & + & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & + & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dy_hypo(k, l, q) + dv_dx_hypo(k, l, q))) + + rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, & + & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & + & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + 2._wp*G_K_field(k, l, q)*(dv_dy_hypo(k, l, q) - (1._wp/3._wp)*(du_dx_hypo(k, l, & + & q) + dv_dy_hypo(k, l, q)))) end do end do end do $:END_GPU_PARALLEL_LOOP() - - elseif (idir == 3) then + else if (idir == 3) then $:GPU_PARALLEL_LOOP(collapse=3) do q = 0, p do l = 0, n do k = 0, m - rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz_hypo(k, l, q) + & - q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz_hypo(k, l, q) - & - q_prim_vf(strxb)%sf(k, l, q)*dw_dz_hypo(k, l, q) - & - 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) - - rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxb + 4)%sf(k, l, q)*du_dz_hypo(k, l, q) + & - q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dz_hypo(k, l, q) - & - q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dz_hypo(k, l, q)) - - rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz_hypo(k, l, q) + & - q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz_hypo(k, l, q) - & - q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dz_hypo(k, l, q) - & - 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) - - rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, q) + & - q_prim_vf(strxb)%sf(k, l, q)*dw_dx_hypo(k, l, q) - & - q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, q) + & - q_prim_vf(strxb + 4)%sf(k, l, q)*du_dy_hypo(k, l, q) + & - q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dy_hypo(k, l, q) - & - q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dy_hypo(k, l, q) + & - q_prim_vf(strxb + 5)%sf(k, l, q)*du_dz_hypo(k, l, q) + & - q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz_hypo(k, l, q) - & - q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz_hypo(k, l, q) + & - 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dz_hypo(k, l, q) + & - dw_dx_hypo(k, l, q))) - - rhs_vf(strxb + 4)%sf(k, l, q) = rhs_vf(strxb + 4)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dx_hypo(k, l, q) + & - q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dx_hypo(k, l, q) - & - q_prim_vf(strxb + 4)%sf(k, l, q)*du_dx_hypo(k, l, q) + & - q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, q) + & - q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dy_hypo(k, l, q) - & - q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, q) + & - q_prim_vf(strxb + 5)%sf(k, l, q)*dv_dz_hypo(k, l, q) + & - q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz_hypo(k, l, q) - & - q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz_hypo(k, l, q) + & - 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(dv_dz_hypo(k, l, q) + & - dw_dy_hypo(k, l, q))) - - rhs_vf(strxe)%sf(k, l, q) = rhs_vf(strxe)%sf(k, l, q) + rho_K_field(k, l, q)* & - (q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx_hypo(k, l, q) + & - q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx_hypo(k, l, q) - & - q_prim_vf(strxe)%sf(k, l, q)*du_dx_hypo(k, l, q) + & - q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy_hypo(k, l, q) + & - q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy_hypo(k, l, q) - & - q_prim_vf(strxe)%sf(k, l, q)*dv_dy_hypo(k, l, q) + & - q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, q) + & - q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, q) - & - q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, q) + & - 2._wp*G_K_field(k, l, q)*(dw_dz_hypo(k, l, q) - (1._wp/3._wp)* & - (du_dx_hypo(k, l, q) + & - dv_dy_hypo(k, l, q) + & - dw_dz_hypo(k, l, q)))) + rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxb + 3)%sf(k, & + & l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz_hypo(k, l, & + & q) - q_prim_vf(strxb)%sf(k, l, q)*dw_dz_hypo(k, l, q) - 2._wp*G_K_field(k, l, & + & q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) + + rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, & + & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & + & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dz_hypo(k, l, q)) + + rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, & + & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & + & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dz_hypo(k, l, & + & q) - 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) + + rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, & + & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & + & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz_hypo(k, l, & + & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dz_hypo(k, l, q) + dw_dx_hypo(k, l, q))) + + rhs_vf(strxb + 4)%sf(k, l, q) = rhs_vf(strxb + 4)%sf(k, l, q) + rho_K_field(k, l, & + & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz_hypo(k, l, & + & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(dv_dz_hypo(k, l, q) + dw_dy_hypo(k, l, q))) + + rhs_vf(strxe)%sf(k, l, q) = rhs_vf(strxe)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxe - 2)%sf(k, & + & l, q)*dw_dx_hypo(k, l, q) + q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx_hypo(k, l, & + & q) - q_prim_vf(strxe)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy_hypo(k, l, & + & q) - q_prim_vf(strxe)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxe)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) + q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, & + & q) - q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, l, q)*(dw_dz_hypo(k, & + & l, q) - (1._wp/3._wp)*(du_dx_hypo(k, l, q) + dv_dy_hypo(k, l, q) + dw_dz_hypo(k, l, q)))) end do end do end do @@ -341,44 +294,37 @@ contains end if if (cyl_coord .and. idir == 2) then - $:GPU_PARALLEL_LOOP(collapse=3) do q = 0, p do l = 0, n do k = 0, m ! S_xx -= rho * v/r * (tau_xx + 2/3*G) - rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) - & - rho_K_field(k, l, q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)* & - (q_prim_vf(strxb)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_xx + 2/3*G + rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) - rho_K_field(k, l, q)*q_prim_vf(momxb + 1)%sf(k, & + & l, q)/y_cc(l)*(q_prim_vf(strxb)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_xx + 2/3*G ! S_xr -= rho * v/r * tau_xr - rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) - & - rho_K_field(k, l, q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)* & - q_prim_vf(strxb + 1)%sf(k, l, q) ! tau_xx + rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) - rho_K_field(k, l, & + & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*q_prim_vf(strxb + 1)%sf(k, l, q) ! tau_xx ! S_rr -= rho * v/r * (tau_rr + 2/3*G) - rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) - & - rho_K_field(k, l, q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)* & - (q_prim_vf(strxb + 2)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_rr + 2/3*G + rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) - rho_K_field(k, l, & + & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*(q_prim_vf(strxb + 2)%sf(k, l, & + & q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_rr + 2/3*G ! S_thetatheta += rho * ( -(tau_thetatheta + 2/3*G)*(du/dx + dv/dr + v/r) + 2*(tau_thetatheta + G)*v/r ) - rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + & - rho_K_field(k, l, q)*( & - -(q_prim_vf(strxb + 3)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q))* & - (du_dx_hypo(k, l, q) + dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)) & - + 2._wp*(q_prim_vf(strxb + 3)%sf(k, l, q) + G_K_field(k, l, q))*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)) + rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, & + & q)*(-(q_prim_vf(strxb + 3)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q))*(du_dx_hypo(k, l, & + & q) + dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, & + & q)/y_cc(l)) + 2._wp*(q_prim_vf(strxb + 3)%sf(k, l, q) + G_K_field(k, l, & + & q))*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)) end do end do end do $:END_GPU_PARALLEL_LOOP() - end if - end subroutine s_compute_hypoelastic_rhs - !> @brief Deallocates arrays used by the hypoelastic stress module. impure subroutine s_finalize_hypoelastic_module() - @:DEALLOCATE(Gs_hypo) @:DEALLOCATE(rho_K_field, G_K_field) @:DEALLOCATE(du_dx_hypo) @@ -391,45 +337,41 @@ contains @:DEALLOCATE(fd_coeff_z_hypo) end if end if - end subroutine s_finalize_hypoelastic_module - !> @brief Computes the continuum damage source term from the principal stress state. subroutine s_compute_damage_state(q_cons_vf, rhs_vf) - - type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - - real(wp) :: tau_p ! principal stress - real(wp) :: tau_xx, tau_xy, tau_yy, tau_zz, tau_yz, tau_xz - real(wp) :: I1, I2, I3, argument, phi, sqrt_term_1, sqrt_term_2, temp - integer :: q, l, k + real(wp) :: tau_p ! principal stress + real(wp) :: tau_xx, tau_xy, tau_yy, tau_zz, tau_yz, tau_xz + real(wp) :: I1, I2, I3, argument, phi, sqrt_term_1, sqrt_term_2, temp + integer :: q, l, k if (n == 0) then l = 0; q = 0 $:GPU_PARALLEL_LOOP() do k = 0, m - rhs_vf(damage_idx)%sf(k, l, q) = (alpha_bar*max(abs(real(q_cons_vf(stress_idx%beg)%sf(k, l, q), kind=wp)) - tau_star, 0._wp))**cont_damage_s + rhs_vf(damage_idx)%sf(k, l, q) = (alpha_bar*max(abs(real(q_cons_vf(stress_idx%beg)%sf(k, l, q), & + & kind=wp)) - tau_star, 0._wp))**cont_damage_s end do $:END_GPU_PARALLEL_LOOP() - elseif (p == 0) then + else if (p == 0) then q = 0 $:GPU_PARALLEL_LOOP(collapse=2, private='[tau_p]') do l = 0, n do k = 0, m ! Maximum principal stress - tau_p = 0.5_wp*(q_cons_vf(stress_idx%beg)%sf(k, l, q) + & - q_cons_vf(stress_idx%beg + 2)%sf(k, l, q)) + & - sqrt((q_cons_vf(stress_idx%beg)%sf(k, l, q) - & - q_cons_vf(stress_idx%beg + 2)%sf(k, l, q))**2.0_wp + & - 4._wp*q_cons_vf(stress_idx%beg + 1)%sf(k, l, q)**2.0_wp)/2._wp + tau_p = 0.5_wp*(q_cons_vf(stress_idx%beg)%sf(k, l, q) + q_cons_vf(stress_idx%beg + 2)%sf(k, l, & + & q)) + sqrt((q_cons_vf(stress_idx%beg)%sf(k, l, q) - q_cons_vf(stress_idx%beg + 2)%sf(k, l, & + & q))**2.0_wp + 4._wp*q_cons_vf(stress_idx%beg + 1)%sf(k, l, q)**2.0_wp)/2._wp rhs_vf(damage_idx)%sf(k, l, q) = (alpha_bar*max(tau_p - tau_star, 0._wp))**cont_damage_s end do end do $:END_GPU_PARALLEL_LOOP() else - $:GPU_PARALLEL_LOOP(collapse=3, private='[tau_xx, tau_xy, tau_yy, tau_xz, tau_yz, tau_zz, I1, I2, I3, temp, sqrt_term_1, sqrt_term_2, argument, phi, tau_p]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[tau_xx, tau_xy, tau_yy, tau_xz, tau_yz, tau_zz, I1, I2, I3, temp, & + & sqrt_term_1, sqrt_term_2, argument, phi, tau_p]') do q = 0, p do l = 0, n do k = 0, m @@ -442,17 +384,15 @@ contains ! Invariants of the stress tensor I1 = tau_xx + tau_yy + tau_zz - I2 = tau_xx*tau_yy + tau_xx*tau_zz + tau_yy*tau_zz - & - (tau_xy**2.0_wp + tau_xz**2.0_wp + tau_yz**2.0_wp) - I3 = tau_xx*tau_yy*tau_zz + 2.0_wp*tau_xy*tau_xz*tau_yz - & - tau_xx*tau_yz**2.0_wp - tau_yy*tau_xz**2.0_wp - tau_zz*tau_xy**2.0_wp + I2 = tau_xx*tau_yy + tau_xx*tau_zz + tau_yy*tau_zz - (tau_xy**2.0_wp + tau_xz**2.0_wp + tau_yz**2.0_wp) + I3 = tau_xx*tau_yy*tau_zz + 2.0_wp*tau_xy*tau_xz*tau_yz - tau_xx*tau_yz**2.0_wp - tau_yy*tau_xz**2.0_wp & + & - tau_zz*tau_xy**2.0_wp ! Maximum principal stress temp = I1**2.0_wp - 3.0_wp*I2 sqrt_term_1 = sqrt(max(temp, 0.0_wp)) if (sqrt_term_1 > verysmall) then ! Avoid 0/0 - argument = (2.0_wp*I1*I1*I1 - 9.0_wp*I1*I2 + 27.0_wp*I3)/ & - (2.0_wp*sqrt_term_1*sqrt_term_1*sqrt_term_1) + argument = (2.0_wp*I1*I1*I1 - 9.0_wp*I1*I2 + 27.0_wp*I3)/(2.0_wp*sqrt_term_1*sqrt_term_1*sqrt_term_1) if (argument > 1.0_wp) argument = 1.0_wp if (argument < -1.0_wp) argument = -1.0_wp phi = acos(argument) @@ -468,7 +408,5 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_compute_damage_state - end module m_hypoelastic diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index d725a3e5f3..130b858c4a 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -11,10 +11,9 @@ !> @brief Immersed boundary patch geometry constructors for 2D and 3D shapes module m_ib_patches + use m_model ! Subroutine(s) related to STL files - use m_model ! Subroutine(s) related to STL files - - use m_derived_types ! Definitions of the derived types + use m_derived_types ! Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -26,14 +25,15 @@ module m_ib_patches implicit none - private; public :: s_apply_ib_patches, s_update_ib_rotation_matrix, f_convert_cyl_to_cart, s_instantiate_STL_models, s_decode_patch_periodicity + private; public :: s_apply_ib_patches, s_update_ib_rotation_matrix, f_convert_cyl_to_cart, s_instantiate_STL_models, & + & s_decode_patch_periodicity real(wp) :: x_centroid, y_centroid, z_centroid real(wp) :: length_x, length_y, length_z $:GPU_DECLARE(create='[x_centroid, y_centroid, z_centroid]') $:GPU_DECLARE(create='[length_x, length_y, length_z]') - integer :: smooth_patch_id + integer :: smooth_patch_id real(wp) :: smooth_coeff $:GPU_DECLARE(create='[smooth_patch_id, smooth_coeff]') !! These variables are analogous in both meaning and use to the similarly @@ -55,20 +55,16 @@ module m_ib_patches !! perform the actions necessary to lay out a particular patch on the grid. character(len=5) :: istr ! string to store int to string result for error checking - contains !> @brief Applies all immersed boundary patch geometries to mark interior cells in the IB marker array. impure subroutine s_apply_ib_patches(ib_markers) - type(integer_field), intent(inout) :: ib_markers - - integer :: i, xp, yp, zp ! iterators - integer :: xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper ! periodic bounds + integer :: i, xp, yp, zp ! iterators + integer :: xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper ! periodic bounds ! 3D Patch Geometries if (p > 0) then - !> IB Patches !> @{ call s_get_periodicities(xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper) @@ -78,13 +74,13 @@ contains do i = 1, num_ibs if (patch_ib(i)%geometry == 8) then call s_ib_sphere(i, ib_markers, xp, yp, zp) - elseif (patch_ib(i)%geometry == 9) then + else if (patch_ib(i)%geometry == 9) then call s_ib_cuboid(i, ib_markers, xp, yp, zp) - elseif (patch_ib(i)%geometry == 10) then + else if (patch_ib(i)%geometry == 10) then call s_ib_cylinder(i, ib_markers, xp, yp, zp) - elseif (patch_ib(i)%geometry == 11) then + else if (patch_ib(i)%geometry == 11) then call s_ib_3D_airfoil(i, ib_markers, xp, yp, zp) - elseif (patch_ib(i)%geometry == 12) then + else if (patch_ib(i)%geometry == 12) then call s_ib_3d_model(i, ib_markers, xp, yp, zp) end if end do @@ -94,8 +90,7 @@ contains !> @} ! 2D Patch Geometries - elseif (n > 0) then - + else if (n > 0) then !> IB Patches !> @{ call s_get_periodicities(xp_lower, xp_upper, yp_lower, yp_upper) @@ -104,42 +99,35 @@ contains do i = 1, num_ibs if (patch_ib(i)%geometry == 2) then call s_ib_circle(i, ib_markers, xp, yp) - elseif (patch_ib(i)%geometry == 3) then + else if (patch_ib(i)%geometry == 3) then call s_ib_rectangle(i, ib_markers, xp, yp) - elseif (patch_ib(i)%geometry == 4) then + else if (patch_ib(i)%geometry == 4) then call s_ib_airfoil(i, ib_markers, xp, yp) - elseif (patch_ib(i)%geometry == 5) then + else if (patch_ib(i)%geometry == 5) then call s_ib_model(i, ib_markers, xp, yp) - elseif (patch_ib(i)%geometry == 6) then + else if (patch_ib(i)%geometry == 6) then call s_ib_ellipse(i, ib_markers, xp, yp) end if end do end do end do !> @} - end if - end subroutine s_apply_ib_patches - - !> The circular patch is a 2D geometry that may be used, for - !! example, in creating a bubble or a droplet. The geometry - !! of the patch is well-defined when its centroid and radius - !! are provided. Note that the circular patch DOES allow for - !! the smoothing of its boundary. + !> The circular patch is a 2D geometry that may be used, for example, in creating a bubble or a droplet. The geometry of the + !! patch is well-defined when its centroid and radius are provided. Note that the circular patch DOES allow for the smoothing of + !! its boundary. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids !! @param ib True if this patch is an immersed boundary subroutine s_ib_circle(patch_id, ib_markers, xp, yp) - - integer, intent(in) :: patch_id - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer, intent(in) :: patch_id + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information type(integer_field), intent(inout) :: ib_markers - - real(wp), dimension(1:2) :: center - real(wp) :: radius - integer :: i, j, il, ir, jl, jr !< Generic loop iterators - integer :: encoded_patch_id + real(wp), dimension(1:2) :: center + real(wp) :: radius + integer :: i, j, il, ir, jl, jr !< Generic loop iterators + integer :: encoded_patch_id ! Transferring the circular patch's radius, centroid, smearing patch ! identity and smearing coefficient information @@ -163,39 +151,31 @@ contains ! that cell. If both queries check out, the primitive variables of ! the current patch are assigned to this cell. - $:GPU_PARALLEL_LOOP(private='[i,j]',& - & copyin='[encoded_patch_id,center,radius]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j]', copyin='[encoded_patch_id, center, radius]', collapse=2) do j = jl, jr do i = il, ir - if ((x_cc(i) - center(1))**2 & - + (y_cc(j) - center(2))**2 <= radius**2) & - then + if ((x_cc(i) - center(1))**2 + (y_cc(j) - center(2))**2 <= radius**2) then ib_markers%sf(i, j, 0) = encoded_patch_id end if end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_circle - !> @brief Marks cells inside a 2D NACA 4-digit airfoil immersed boundary using upper and lower surface grids. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_airfoil(patch_id, ib_markers, xp, yp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information - - real(wp) :: f, ca_in, pa, ma, ta - real(wp) :: xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c - integer :: i, j, k, il, ir, jl, jr - integer :: Np1, Np2 - integer :: encoded_patch_id - - real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + real(wp) :: f, ca_in, pa, ma, ta + real(wp) :: xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c + integer :: i, j, k, il, ir, jl, jr + integer :: Np1, Np2 + integer :: encoded_patch_id + real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: inverse_rotation center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) @@ -203,7 +183,7 @@ contains pa = patch_ib(patch_id)%p ma = patch_ib(patch_id)%m ta = patch_ib(patch_id)%t - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) offset(:) = patch_ib(patch_id)%centroid_offset(:) Np1 = int((pa*ca_in/dx(0))*20) @@ -223,7 +203,8 @@ contains airfoil_grid_l(1)%y = 0._wp do i = 1, Np1 + Np2 - 1 - ! TODO :: This allocated the upper and lower airfoil arrays, and does not need to be performed each time the IB markers are updated. Place this as a separate subroutine. + ! TODO :: This allocated the upper and lower airfoil arrays, and does not need to be performed each time the IB + ! markers are updated. Place this as a separate subroutine. if (i <= Np1) then xc = i*(pa*ca_in/Np1) xa = xc/ca_in @@ -257,7 +238,6 @@ contains airfoil_grid_l(i + 1)%x = xl airfoil_grid_l(i + 1)%y = yl - end do airfoil_grid_u(Np)%x = ca_in @@ -266,8 +246,7 @@ contains airfoil_grid_l(Np)%x = ca_in airfoil_grid_l(Np)%y = 0._wp - $:GPU_UPDATE(device='[airfoil_grid_l,airfoil_grid_u]') - + $:GPU_UPDATE(device='[airfoil_grid_l, airfoil_grid_u]') end if ! encode the periodicity information into the patch_id @@ -282,8 +261,8 @@ contains call get_bounding_indices(center(1) - ca_in, center(1) + ca_in, x_cc, il, ir) call get_bounding_indices(center(2) - ca_in, center(2) + ca_in, y_cc, jl, jr) - $:GPU_PARALLEL_LOOP(private='[i,j,xy_local,k,f]', & - & copyin='[encoded_patch_id,center,inverse_rotation,offset,ma,ca_in,airfoil_grid_u,airfoil_grid_l]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local, k, f]', copyin='[encoded_patch_id, center, inverse_rotation, offset, ma, & + & ca_in, airfoil_grid_u, airfoil_grid_l]', collapse=2) do j = jl, jr do i = il, ir xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] ! get coordinate frame centered on IB @@ -339,26 +318,21 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_airfoil - !> @brief Marks cells inside a 3D extruded NACA 4-digit airfoil immersed boundary with finite span. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids !! @param ib True if this patch is an immersed boundary subroutine s_ib_3D_airfoil(patch_id, ib_markers, xp, yp, zp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - - real(wp) :: lz, z_max, z_min, f, ca_in, pa, ma, ta, xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c - integer :: i, j, k, l, il, ir, jl, jr, ll, lr - integer :: Np1, Np2 - integer :: encoded_patch_id - - real(wp), dimension(1:3) :: xyz_local, center, offset !< x, y, z coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + real(wp) :: lz, z_max, z_min, f, ca_in, pa, ma, ta, xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c + integer :: i, j, k, l, il, ir, jl, jr, ll, lr + integer :: Np1, Np2 + integer :: encoded_patch_id + real(wp), dimension(1:3) :: xyz_local, center, offset !< x, y, z coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: inverse_rotation center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) @@ -368,7 +342,7 @@ contains pa = patch_ib(patch_id)%p ma = patch_ib(patch_id)%m ta = patch_ib(patch_id)%t - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) offset(:) = patch_ib(patch_id)%centroid_offset(:) z_max = lz/2 @@ -380,7 +354,6 @@ contains $:GPU_UPDATE(device='[Np]') if (.not. allocated(airfoil_grid_u)) then - @:ALLOCATE(airfoil_grid_u(1:Np)) @:ALLOCATE(airfoil_grid_l(1:Np)) @@ -424,7 +397,6 @@ contains airfoil_grid_l(i + 1)%x = xl airfoil_grid_l(i + 1)%y = yl - end do airfoil_grid_u(Np)%x = ca_in @@ -433,7 +405,7 @@ contains airfoil_grid_l(Np)%x = ca_in airfoil_grid_l(Np)%y = 0._wp - $:GPU_UPDATE(device='[airfoil_grid_l,airfoil_grid_u]') + $:GPU_UPDATE(device='[airfoil_grid_l, airfoil_grid_u]') end if ! encode the periodicity information into the patch_id @@ -451,17 +423,17 @@ contains call get_bounding_indices(center(2) - ca_in, center(2) + ca_in, y_cc, jl, jr) call get_bounding_indices(center(3) - ca_in, center(3) + ca_in, z_cc, ll, lr) - $:GPU_PARALLEL_LOOP(private='[i,j,l,xyz_local,k,f]',& - & copyin='[encoded_patch_id,center,inverse_rotation,offset,ma,ca_in,airfoil_grid_u,airfoil_grid_l,z_min,z_max]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, l, xyz_local, k, f]', copyin='[encoded_patch_id, center, inverse_rotation, offset, ma, & + & ca_in, airfoil_grid_u, airfoil_grid_l, z_min, z_max]', collapse=3) do l = ll, lr do j = jl, jr do i = il, ir - xyz_local = [x_cc(i) - center(1), y_cc(j) - center(2), z_cc(l) - center(3)] ! get coordinate frame centered on IB + xyz_local = [x_cc(i) - center(1), y_cc(j) - center(2), & + & z_cc(l) - center(3)] ! get coordinate frame centered on IB xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates xyz_local = xyz_local - offset ! airfoils are a patch that require a centroid offset if (xyz_local(3) >= z_min .and. xyz_local(3) <= z_max) then - if (xyz_local(1) >= 0._wp .and. xyz_local(1) <= ca_in) then if (xyz_local(2) >= 0._wp) then k = 1 @@ -470,7 +442,7 @@ contains end do if (f_approx_equal(airfoil_grid_u(k)%x, xyz_local(1))) then if (xyz_local(2) <= airfoil_grid_u(k)%y) then - !IB + ! IB ib_markers%sf(i, j, l) = encoded_patch_id end if else @@ -505,39 +477,31 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_3D_airfoil - - !> The rectangular patch is a 2D geometry that may be used, - !! for example, in creating a solid boundary, or pre-/post- - !! shock region, in alignment with the axes of the Cartesian - !! coordinate system. The geometry of such a patch is well- - !! defined when its centroid and lengths in the x- and y- - !! coordinate directions are provided. Please note that the - !! rectangular patch DOES NOT allow for the smoothing of its - !! boundaries. + !> The rectangular patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock + !! region, in alignment with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its + !! centroid and lengths in the x- and y- coordinate directions are provided. Please note that the rectangular patch DOES NOT + !! allow for the smoothing of its boundaries. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids !! @param ib True if this patch is an immersed boundary subroutine s_ib_rectangle(patch_id, ib_markers, xp, yp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information - - integer :: i, j, il, ir, jl, jr !< generic loop iterators - integer :: encoded_patch_id - real(wp) :: corner_distance !< Equation of state parameters - real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: length, center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer :: i, j, il, ir, jl, jr !< generic loop iterators + integer :: encoded_patch_id + real(wp) :: corner_distance !< Equation of state parameters + real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: length, center !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: inverse_rotation ! Transferring the rectangle's centroid and length information center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) length(1) = patch_ib(patch_id)%length_x length(2) = patch_ib(patch_id)%length_y - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) ! encode the periodicity information into the patch_id call s_encode_patch_periodicity(patch_id, xp, yp, 0, encoded_patch_id) @@ -555,48 +519,38 @@ contains ! domain and verifying whether the current patch has the permission ! to write to that cell. If both queries check out, the primitive ! variables of the current patch are assigned to this cell. - $:GPU_PARALLEL_LOOP(private='[i,j, xy_local]',& - & copyin='[encoded_patch_id,center,length,inverse_rotation,x_cc,y_cc]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', copyin='[encoded_patch_id, center, length, inverse_rotation, x_cc, y_cc]', collapse=2) do j = jl, jr do i = il, ir ! get the x and y coordinates in the local IB frame xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] xy_local = matmul(inverse_rotation, xy_local) - if (-0.5_wp*length(1) <= xy_local(1) .and. & - 0.5_wp*length(1) >= xy_local(1) .and. & - -0.5_wp*length(2) <= xy_local(2) .and. & - 0.5_wp*length(2) >= xy_local(2)) then - + if (-0.5_wp*length(1) <= xy_local(1) .and. 0.5_wp*length(1) >= xy_local(1) .and. -0.5_wp*length(2) <= xy_local(2) & + & .and. 0.5_wp*length(2) >= xy_local(2)) then ! Updating the patch identities bookkeeping variable ib_markers%sf(i, j, 0) = encoded_patch_id - end if end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_rectangle - - !> The spherical patch is a 3D geometry that may be used, - !! for example, in creating a bubble or a droplet. The patch - !! geometry is well-defined when its centroid and radius are - !! provided. Please note that the spherical patch DOES allow - !! for the smoothing of its boundary. + !> The spherical patch is a 3D geometry that may be used, for example, in creating a bubble or a droplet. The patch geometry is + !! well-defined when its centroid and radius are provided. Please note that the spherical patch DOES allow for the smoothing of + !! its boundary. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids !! @param ib True if this patch is an immersed boundary subroutine s_ib_sphere(patch_id, ib_markers, xp, yp, zp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information ! Generic loop iterators - integer :: i, j, k - integer :: il, ir, jl, jr, kl, kr - integer :: encoded_patch_id - real(wp) :: radius + integer :: i, j, k + integer :: il, ir, jl, jr, kl, kr + integer :: encoded_patch_id + real(wp) :: radius real(wp), dimension(1:3) :: center !! Variables to initialize the pressure field that corresponds to the @@ -627,8 +581,7 @@ contains ! and verifying whether the current patch has permission to write to ! that cell. If both queries check out, the primitive variables of ! the current patch are assigned to this cell. - $:GPU_PARALLEL_LOOP(private='[i,j,k,cart_y,cart_z]',& - & copyin='[encoded_patch_id,center,radius]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, cart_y, cart_z]', copyin='[encoded_patch_id, center, radius]', collapse=3) do k = kl, kr do j = jl, jr do i = il, ir @@ -640,39 +593,29 @@ contains cart_z = z_cc(k) end if ! Updating the patch identities bookkeeping variable - if (((x_cc(i) - center(1))**2 & - + (cart_y - center(2))**2 & - + (cart_z - center(3))**2 <= radius**2)) then + if (((x_cc(i) - center(1))**2 + (cart_y - center(2))**2 + (cart_z - center(3))**2 <= radius**2)) then ib_markers%sf(i, j, k) = encoded_patch_id end if end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_sphere - - !> The cuboidal patch is a 3D geometry that may be used, for - !! example, in creating a solid boundary, or pre-/post-shock - !! region, which is aligned with the axes of the Cartesian - !! coordinate system. The geometry of such a patch is well- - !! defined when its centroid and lengths in the x-, y- and - !! z-coordinate directions are provided. Please notice that - !! the cuboidal patch DOES NOT allow for the smearing of its - !! boundaries. + !> The cuboidal patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post-shock region, + !! which is aligned with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its + !! centroid and lengths in the x-, y- and z-coordinate directions are provided. Please notice that the cuboidal patch DOES NOT + !! allow for the smearing of its boundaries. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_cuboid(patch_id, ib_markers, xp, yp, zp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - - integer :: i, j, k, ir, il, jr, jl, kr, kl !< Generic loop iterators - integer :: encoded_patch_id - real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation - real(wp) :: corner_distance + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer :: i, j, k, ir, il, jr, jl, kr, kl !< Generic loop iterators + integer :: encoded_patch_id + real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: inverse_rotation + real(wp) :: corner_distance ! Transferring the cuboid's centroid and length information center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) @@ -681,7 +624,7 @@ contains length(1) = patch_ib(patch_id)%length_x length(2) = patch_ib(patch_id)%length_y length(3) = patch_ib(patch_id)%length_z - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) ! encode the periodicity information into the patch_id call s_encode_patch_periodicity(patch_id, xp, yp, zp, encoded_patch_id) @@ -702,12 +645,11 @@ contains ! and verifying whether the current patch has permission to write to ! to that cell. If both queries check out, the primitive variables ! of the current patch are assigned to this cell. - $:GPU_PARALLEL_LOOP(private='[i,j,k,xyz_local,cart_y,cart_z]',& - & copyin='[encoded_patch_id,center,length,inverse_rotation]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, xyz_local, cart_y, cart_z]', copyin='[encoded_patch_id, center, length, & + & inverse_rotation]', collapse=3) do k = kl, kr do j = jl, jr do i = il, ir - if (grid_geometry == 3) then ! TODO :: This does not work and is not covered by any tests. This should be fixed call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) @@ -718,13 +660,9 @@ contains xyz_local = [x_cc(i), cart_y, cart_z] - center ! get coordinate frame centered on IB xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates - if (-0.5*length(1) <= xyz_local(1) .and. & - 0.5*length(1) >= xyz_local(1) .and. & - -0.5*length(2) <= xyz_local(2) .and. & - 0.5*length(2) >= xyz_local(2) .and. & - -0.5*length(3) <= xyz_local(3) .and. & - 0.5*length(3) >= xyz_local(3)) then - + if (-0.5*length(1) <= xyz_local(1) .and. 0.5*length(1) >= xyz_local(1) .and. -0.5*length(2) <= xyz_local(2) & + & .and. 0.5*length(2) >= xyz_local(2) .and. -0.5*length(3) <= xyz_local(3) .and. 0.5*length(3) & + & >= xyz_local(3)) then ! Updating the patch identities bookkeeping variable ib_markers%sf(i, j, k) = encoded_patch_id end if @@ -732,32 +670,24 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_cuboid - - !> The cylindrical patch is a 3D geometry that may be used, - !! for example, in setting up a cylindrical solid boundary - !! confinement, like a blood vessel. The geometry of this - !! patch is well-defined when the centroid, the radius and - !! the length along the cylinder's axis, parallel to the x-, - !! y- or z-coordinate direction, are provided. Please note - !! that the cylindrical patch DOES allow for the smoothing - !! of its lateral boundary. + !> The cylindrical patch is a 3D geometry that may be used, for example, in setting up a cylindrical solid boundary confinement, + !! like a blood vessel. The geometry of this patch is well-defined when the centroid, the radius and the length along the + !! cylinder's axis, parallel to the x-, y- or z-coordinate direction, are provided. Please note that the cylindrical patch DOES + !! allow for the smoothing of its lateral boundary. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids !! @param ib True if this patch is an immersed boundary subroutine s_ib_cylinder(patch_id, ib_markers, xp, yp, zp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - - integer :: i, j, k, il, ir, jl, jr, kl, kr !< Generic loop iterators - integer :: encoded_patch_id - real(wp) :: radius - real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation - real(wp) :: corner_distance + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer :: i, j, k, il, ir, jl, jr, kl, kr !< Generic loop iterators + integer :: encoded_patch_id + real(wp) :: radius + real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: inverse_rotation + real(wp) :: corner_distance ! Transferring the cylindrical patch's centroid, length, radius, center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) @@ -767,7 +697,7 @@ contains length(2) = patch_ib(patch_id)%length_y length(3) = patch_ib(patch_id)%length_z radius = patch_ib(patch_id)%radius - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) ! encode the periodicity information into the patch_id call s_encode_patch_periodicity(patch_id, xp, yp, zp, encoded_patch_id) @@ -787,12 +717,11 @@ contains ! domain and verifying whether the current patch has the permission ! to write to that cell. If both queries check out, the primitive ! variables of the current patch are assigned to this cell. - $:GPU_PARALLEL_LOOP(private='[i,j,k,xyz_local,cart_y,cart_z]',& - & copyin='[encoded_patch_id,center,length,radius,inverse_rotation]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, xyz_local, cart_y, cart_z]', copyin='[encoded_patch_id, center, length, radius, & + & inverse_rotation]', collapse=3) do k = kl, kr do j = jl, jr do i = il, ir - if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else @@ -802,24 +731,12 @@ contains xyz_local = [x_cc(i), cart_y, cart_z] - center ! get coordinate frame centered on IB xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates - if (((.not. f_is_default(length(1)) .and. & - xyz_local(2)**2 & - + xyz_local(3)**2 <= radius**2 .and. & - -0.5_wp*length(1) <= xyz_local(1) .and. & - 0.5_wp*length(1) >= xyz_local(1)) & - .or. & - (.not. f_is_default(length(2)) .and. & - xyz_local(1)**2 & - + xyz_local(3)**2 <= radius**2 .and. & - -0.5_wp*length(2) <= xyz_local(2) .and. & - 0.5_wp*length(2) >= xyz_local(2)) & - .or. & - (.not. f_is_default(length(3)) .and. & - xyz_local(1)**2 & - + xyz_local(2)**2 <= radius**2 .and. & - -0.5_wp*length(3) <= xyz_local(3) .and. & - 0.5_wp*length(3) >= xyz_local(3)))) then - + if (((.not. f_is_default(length(1)) .and. xyz_local(2)**2 + xyz_local(3)**2 <= radius**2 .and. & + & -0.5_wp*length(1) <= xyz_local(1) .and. 0.5_wp*length(1) >= xyz_local(1)) & + & .or. (.not. f_is_default(length(2)) .and. xyz_local(1)**2 + xyz_local(3)**2 <= radius**2 .and. & + & -0.5_wp*length(2) <= xyz_local(2) .and. 0.5_wp*length(2) >= xyz_local(2)) & + & .or. (.not. f_is_default(length(3)) .and. xyz_local(1)**2 + xyz_local(2)**2 <= radius**2 .and. & + & -0.5_wp*length(3) <= xyz_local(3) .and. 0.5_wp*length(3) >= xyz_local(3)))) then ! Updating the patch identities bookkeeping variable ib_markers%sf(i, j, k) = encoded_patch_id end if @@ -827,29 +744,25 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_cylinder - !> @brief Marks cells inside a 2D elliptical immersed boundary defined by semi-axis lengths and rotation. subroutine s_ib_ellipse(patch_id, ib_markers, xp, yp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information - - integer :: i, j, il, ir, jl, jr !< Generic loop iterators - integer :: encoded_patch_id - real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: ellipse_coeffs !< a and b in the ellipse coefficients - real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer :: i, j, il, ir, jl, jr !< Generic loop iterators + integer :: encoded_patch_id + real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: ellipse_coeffs !< a and b in the ellipse coefficients + real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: inverse_rotation ! Transferring the ellipse's centroid and length information center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) ellipse_coeffs(1) = 0.5_wp*patch_ib(patch_id)%length_x ellipse_coeffs(2) = 0.5_wp*patch_ib(patch_id)%length_y - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) ! encode the periodicity information into the patch_id call s_encode_patch_periodicity(patch_id, xp, yp, 0, encoded_patch_id) @@ -864,8 +777,8 @@ contains ! Checking whether the ellipse covers a particular cell in the ! domain - $:GPU_PARALLEL_LOOP(private='[i,j, xy_local]',& - & copyin='[encoded_patch_id,center,ellipse_coeffs,inverse_rotation,x_cc,y_cc]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', copyin='[encoded_patch_id, center, ellipse_coeffs, inverse_rotation, x_cc, & + & y_cc]', collapse=2) do j = jl, jr do i = il, ir ! get the x and y coordinates in the local IB frame @@ -880,35 +793,30 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_ellipse - !> The STL patch is a 2D geometry that is imported from an STL file. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_model(patch_id, ib_markers, xp, yp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information - - integer :: i, j, k, il, ir, jl, jr !< Generic loop iterators - integer :: spc, encoded_patch_id - integer :: cx, cy - real(wp) :: lx(2), ly(2) - real(wp), dimension(1:2) :: bbox_min, bbox_max - real(wp), dimension(1:3) :: local_corner, world_corner - - real(wp) :: eta, threshold - real(wp), dimension(1:3) :: point, local_point, offset - real(wp), dimension(1:3) :: center, xy_local - real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer :: i, j, k, il, ir, jl, jr !< Generic loop iterators + integer :: spc, encoded_patch_id + integer :: cx, cy + real(wp) :: lx(2), ly(2) + real(wp), dimension(1:2) :: bbox_min, bbox_max + real(wp), dimension(1:3) :: local_corner, world_corner + real(wp) :: eta, threshold + real(wp), dimension(1:3) :: point, local_point, offset + real(wp), dimension(1:3) :: center, xy_local + real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation center = 0._wp center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) - rotation(:, :) = patch_ib(patch_id)%rotation_matrix(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) + rotation(:,:) = patch_ib(patch_id)%rotation_matrix(:,:) offset(:) = patch_ib(patch_id)%centroid_offset(:) spc = patch_ib(patch_id)%model_spc threshold = patch_ib(patch_id)%model_threshold @@ -945,16 +853,15 @@ contains call get_bounding_indices(bbox_min(1), bbox_max(1), x_cc, il, ir) call get_bounding_indices(bbox_min(2), bbox_max(2), y_cc, jl, jr) - $:GPU_PARALLEL_LOOP(private='[i,j, xy_local, eta]',& - & copyin='[patch_id,encoded_patch_id,center,inverse_rotation, offset, spc, threshold]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local, eta]', copyin='[patch_id, encoded_patch_id, center, inverse_rotation, offset, & + & spc, threshold]', collapse=2) do i = il, ir do j = jl, jr xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] xy_local = matmul(inverse_rotation, xy_local) xy_local = xy_local - offset - eta = f_model_is_inside_flat(gpu_ntrs(patch_id), & - patch_id, xy_local) + eta = f_model_is_inside_flat(gpu_ntrs(patch_id), patch_id, xy_local) ! Reading STL boundary vertices and compute the levelset and levelset_norm if (eta > threshold) then @@ -963,38 +870,33 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_model - !> The STL patch is a 3D geometry that is imported from an STL file. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_3d_model(patch_id, ib_markers, xp, yp, zp) - - integer, intent(in) :: patch_id + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - - integer :: i, j, k, il, ir, jl, jr, kl, kr !< Generic loop iterators - integer :: spc, encoded_patch_id - - real(wp) :: eta, threshold, corner_distance - real(wp), dimension(1:3) :: point, local_point, offset - real(wp), dimension(1:3) :: center, xyz_local - real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation - integer :: cx, cy, cz - real(wp) :: lx(2), ly(2), lz(2) - real(wp), dimension(1:3) :: bbox_min, bbox_max, local_corner, world_corner + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer :: i, j, k, il, ir, jl, jr, kl, kr !< Generic loop iterators + integer :: spc, encoded_patch_id + real(wp) :: eta, threshold, corner_distance + real(wp), dimension(1:3) :: point, local_point, offset + real(wp), dimension(1:3) :: center, xyz_local + real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation + integer :: cx, cy, cz + real(wp) :: lx(2), ly(2), lz(2) + real(wp), dimension(1:3) :: bbox_min, bbox_max, local_corner, world_corner center = 0._wp center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) center(3) = patch_ib(patch_id)%z_centroid + real(zp, wp)*(z_domain%end - z_domain%beg) - inverse_rotation(:, :) = patch_ib(patch_id)%rotation_matrix_inverse(:, :) + inverse_rotation(:,:) = patch_ib(patch_id)%rotation_matrix_inverse(:,:) offset(:) = patch_ib(patch_id)%centroid_offset(:) spc = patch_ib(patch_id)%model_spc threshold = patch_ib(patch_id)%model_threshold - rotation(:, :) = patch_ib(patch_id)%rotation_matrix(:, :) + rotation(:,:) = patch_ib(patch_id)%rotation_matrix(:,:) ! encode the periodicity information into the patch_id call s_encode_patch_periodicity(patch_id, xp, yp, zp, encoded_patch_id) @@ -1037,8 +939,8 @@ contains call get_bounding_indices(bbox_min(2), bbox_max(2), y_cc, jl, jr) call get_bounding_indices(bbox_min(3), bbox_max(3), z_cc, kl, kr) - $:GPU_PARALLEL_LOOP(private='[i,j,k, xyz_local, eta]',& - & copyin='[patch_id,encoded_patch_id,center,inverse_rotation, offset, spc, threshold]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, xyz_local, eta]', copyin='[patch_id, encoded_patch_id, center, inverse_rotation, & + & offset, spc, threshold]', collapse=3) do i = il, ir do j = jl, jr do k = kl, kr @@ -1046,8 +948,7 @@ contains xyz_local = matmul(inverse_rotation, xyz_local) xyz_local = xyz_local - offset - eta = f_model_is_inside_flat(gpu_ntrs(patch_id), & - patch_id, xyz_local) + eta = f_model_is_inside_flat(gpu_ntrs(patch_id), patch_id, xyz_local) if (eta > patch_ib(patch_id)%model_threshold) then ib_markers%sf(i, j, k) = encoded_patch_id @@ -1056,54 +957,49 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_ib_3d_model - !> Subroutine that computes a rotation matrix for converting to the rotating frame of the boundary subroutine s_update_ib_rotation_matrix(patch_id) - - integer, intent(in) :: patch_id - integer :: i - + integer, intent(in) :: patch_id + integer :: i real(wp), dimension(3, 3, 3) :: rotation - real(wp) :: angle + real(wp) :: angle ! construct the x, y, and z rotation matrices if (num_dims == 3) then ! also compute the x and y axes in 3D angle = patch_ib(patch_id)%angles(1) - rotation(1, 1, :) = [1._wp, 0._wp, 0._wp] - rotation(1, 2, :) = [0._wp, cos(angle), -sin(angle)] - rotation(1, 3, :) = [0._wp, sin(angle), cos(angle)] + rotation(1, 1,:) = [1._wp, 0._wp, 0._wp] + rotation(1, 2,:) = [0._wp, cos(angle), -sin(angle)] + rotation(1, 3,:) = [0._wp, sin(angle), cos(angle)] angle = patch_ib(patch_id)%angles(2) - rotation(2, 1, :) = [cos(angle), 0._wp, sin(angle)] - rotation(2, 2, :) = [0._wp, 1._wp, 0._wp] - rotation(2, 3, :) = [-sin(angle), 0._wp, cos(angle)] + rotation(2, 1,:) = [cos(angle), 0._wp, sin(angle)] + rotation(2, 2,:) = [0._wp, 1._wp, 0._wp] + rotation(2, 3,:) = [-sin(angle), 0._wp, cos(angle)] ! apply the y rotation to the x rotation - patch_ib(patch_id)%rotation_matrix(:, :) = matmul(rotation(1, :, :), rotation(2, :, :)) - patch_ib(patch_id)%rotation_matrix_inverse(:, :) = matmul(transpose(rotation(2, :, :)), transpose(rotation(1, :, :))) + patch_ib(patch_id)%rotation_matrix(:,:) = matmul(rotation(1,:,:), rotation(2,:,:)) + patch_ib(patch_id)%rotation_matrix_inverse(:,:) = matmul(transpose(rotation(2,:,:)), transpose(rotation(1,:,:))) end if ! z component first, since it applies in 2D and 3D angle = patch_ib(patch_id)%angles(3) - rotation(3, 1, :) = [cos(angle), -sin(angle), 0._wp] - rotation(3, 2, :) = [sin(angle), cos(angle), 0._wp] - rotation(3, 3, :) = [0._wp, 0._wp, 1._wp] + rotation(3, 1,:) = [cos(angle), -sin(angle), 0._wp] + rotation(3, 2,:) = [sin(angle), cos(angle), 0._wp] + rotation(3, 3,:) = [0._wp, 0._wp, 1._wp] if (num_dims == 3) then ! apply the z rotation to the xy rotation in 3D - patch_ib(patch_id)%rotation_matrix(:, :) = matmul(patch_ib(patch_id)%rotation_matrix(:, :), rotation(3, :, :)) - patch_ib(patch_id)%rotation_matrix_inverse(:, :) = matmul(transpose(rotation(3, :, :)), patch_ib(patch_id)%rotation_matrix_inverse(:, :)) + patch_ib(patch_id)%rotation_matrix(:,:) = matmul(patch_ib(patch_id)%rotation_matrix(:,:), rotation(3,:,:)) + patch_ib(patch_id)%rotation_matrix_inverse(:,:) = matmul(transpose(rotation(3,:,:)), & + & patch_ib(patch_id)%rotation_matrix_inverse(:,:)) else ! write out only the z rotation in 2D - patch_ib(patch_id)%rotation_matrix(:, :) = rotation(3, :, :) - patch_ib(patch_id)%rotation_matrix_inverse(:, :) = transpose(rotation(3, :, :)) + patch_ib(patch_id)%rotation_matrix(:,:) = rotation(3,:,:) + patch_ib(patch_id)%rotation_matrix_inverse(:,:) = transpose(rotation(3,:,:)) end if - end subroutine s_update_ib_rotation_matrix - !> @brief Converts cylindrical (r, theta) coordinates to Cartesian (y, z) and stores in module variables. subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) $:GPU_ROUTINE(parallelism='[seq]') @@ -1112,40 +1008,29 @@ contains cart_y = cyl_y*sin(cyl_z) cart_z = cyl_y*cos(cyl_z) - end subroutine s_convert_cylindrical_to_cartesian_coord - !> @brief Converts a 3D cylindrical coordinate vector (x, r, theta) to Cartesian (x, y, z). pure function f_convert_cyl_to_cart(cyl) result(cart) - $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(1:3), intent(in) :: cyl - real(wp), dimension(1:3) :: cart - - cart = (/cyl(1), & - cyl(2)*sin(cyl(3)), & - cyl(2)*cos(cyl(3))/) + real(wp), dimension(1:3) :: cart + cart = (/cyl(1), cyl(2)*sin(cyl(3)), cyl(2)*cos(cyl(3))/) end function f_convert_cyl_to_cart - !> @brief Converts cylindrical coordinates (x, r) to the spherical azimuthal angle phi and stores in a module variable. subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(IN) :: cyl_x, cyl_y + real(wp), intent(in) :: cyl_x, cyl_y sph_phi = atan(cyl_y/cyl_x) - end subroutine s_convert_cylindrical_to_spherical_coord - subroutine get_bounding_indices(left_bound, right_bound, cell_centers, left_index, right_index) - - real(wp), intent(in) :: left_bound, right_bound - integer, intent(inout) :: left_index, right_index + real(wp), intent(in) :: left_bound, right_bound + integer, intent(inout) :: left_index, right_index real(wp), dimension(-buff_size:), intent(in) :: cell_centers - - integer :: itr_left, itr_middle, itr_right + integer :: itr_left, itr_middle, itr_right itr_left = left_index itr_right = right_index @@ -1176,16 +1061,12 @@ contains end if end do right_index = itr_right - end subroutine get_bounding_indices - !> @brief encodes the patch id with a unique offset that contains information on how the IB marker wraps periodically subroutine s_encode_patch_periodicity(patch_id, x_periodicity, y_periodicity, z_periodicity, encoded_patch_id) - - integer, intent(in) :: patch_id, x_periodicity, y_periodicity, z_periodicity + integer, intent(in) :: patch_id, x_periodicity, y_periodicity, z_periodicity integer, intent(out) :: encoded_patch_id - - integer :: temp_x_per, temp_y_per, temp_z_per, offset + integer :: temp_x_per, temp_y_per, temp_z_per, offset encoded_patch_id = patch_id @@ -1195,18 +1076,14 @@ contains offset = (num_ibs + 1)*temp_x_per + 3*(num_ibs + 1)*temp_y_per + 9*(num_ibs + 1)*temp_z_per encoded_patch_id = patch_id + offset - end subroutine s_encode_patch_periodicity - !> @brief decodes the encoded id to get out the original id and the way in which it is periodic subroutine s_decode_patch_periodicity(encoded_patch_id, patch_id, x_periodicity, y_periodicity, z_periodicity) - $:GPU_ROUTINE(parallelism='[seq]') - integer, intent(in) :: encoded_patch_id + integer, intent(in) :: encoded_patch_id integer, intent(out) :: patch_id, x_periodicity, y_periodicity, z_periodicity - - integer :: offset, remainder, xp, yp, zp, base + integer :: offset, remainder, xp, yp, zp, base base = num_ibs + 1 @@ -1222,13 +1099,10 @@ contains x_periodicity = xp; if (xp == 2) x_periodicity = -1 y_periodicity = yp; if (yp == 2) y_periodicity = -1 z_periodicity = zp; if (zp == 2) z_periodicity = -1 - end subroutine s_decode_patch_periodicity - !> @brief Determines if we should wrap periodically subroutine s_get_periodicities(xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper) - - integer, intent(out) :: xp_lower, xp_upper, yp_lower, yp_upper + integer, intent(out) :: xp_lower, xp_upper, yp_lower, yp_upper integer, intent(out), optional :: zp_lower, zp_upper ! check domain wraps in x, y @@ -1238,7 +1112,7 @@ contains ${X}$p_lower = -1 ${X}$p_upper = 1 else - !if it is not periodic, then both elements are 0 + ! if it is not periodic, then both elements are 0 ${X}$p_lower = 0 ${X}$p_upper = 0 end if @@ -1254,9 +1128,7 @@ contains zp_upper = 0 end if end if - end subroutine s_get_periodicities - !> Archimedes spiral function !! @param myth Angle !! @param offset Thickness @@ -1264,13 +1136,12 @@ contains pure elemental function f_r(myth, offset, a) $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: myth, offset, a - real(wp) :: b - real(wp) :: f_r + real(wp) :: b + real(wp) :: f_r - !r(th) = a + b*th + ! r(th) = a + b*th b = 2._wp*a/(2._wp*pi) f_r = a + b*myth + offset end function f_r - end module m_ib_patches diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index ad856135f6..96e484c1fc 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -4,9 +4,9 @@ #:include 'macros.fpp' -!> @brief Ghost-node immersed boundary method: locates ghost/image points, computes interpolation coefficients, and corrects the flow state +!> @brief Ghost-node immersed boundary method: locates ghost/image points, computes interpolation coefficients, and corrects the +!! flow state module m_ibm - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -31,15 +31,9 @@ module m_ibm implicit none - private :: s_compute_image_points, & - s_compute_interpolation_coeffs, & - s_interpolate_image_point, & - s_find_ghost_points, & - s_find_num_ghost_points - ; public :: s_initialize_ibm_module, & - s_ibm_setup, & - s_ibm_correct_state, & - s_finalize_ibm_module + private :: s_compute_image_points, s_compute_interpolation_coeffs, s_interpolate_image_point, s_find_ghost_points, & + & s_find_num_ghost_points + ; public :: s_initialize_ibm_module, s_ibm_setup, s_ibm_correct_state, s_finalize_ibm_module type(integer_field), public :: ib_markers $:GPU_DECLARE(create='[ib_markers]') @@ -49,23 +43,19 @@ module m_ibm integer :: num_gps !< Number of ghost points #if defined(MFC_OpenACC) - $:GPU_DECLARE(create='[gp_layers,num_gps]') + $:GPU_DECLARE(create='[gp_layers, num_gps]') #elif defined(MFC_OpenMP) $:GPU_DECLARE(create='[num_gps]') #endif logical :: moving_immersed_boundary_flag - contains - !> Allocates memory for the variables in the IBM module + !> Allocates memory for the variables in the IBM module impure subroutine s_initialize_ibm_module() - if (p > 0) then - @:ALLOCATE(ib_markers%sf(-buff_size:m+buff_size, & - -buff_size:n+buff_size, -buff_size:p+buff_size)) + @:ALLOCATE(ib_markers%sf(-buff_size:m+buff_size, -buff_size:n+buff_size, -buff_size:p+buff_size)) else - @:ALLOCATE(ib_markers%sf(-buff_size:m+buff_size, & - -buff_size:n+buff_size, 0:0)) + @:ALLOCATE(ib_markers%sf(-buff_size:m+buff_size, -buff_size:n+buff_size, 0:0)) end if @:ALLOCATE(models(num_ibs)) @@ -73,13 +63,9 @@ contains @:ACC_SETUP_SFs(ib_markers) $:GPU_ENTER_DATA(copyin='[num_gps]') - end subroutine s_initialize_ibm_module - - !> Initializes the values of various IBM variables, such as ghost points and - !! image points. + !> Initializes the values of various IBM variables, such as ghost points and image points. impure subroutine s_ibm_setup() - integer :: i, j, k integer :: max_num_gps @@ -136,46 +122,35 @@ contains call s_compute_interpolation_coeffs(ghost_points) call nvtxEndRange - end subroutine s_ibm_setup - - !> Subroutine that updates the conservative variables at the ghost points - !! @param pb_in Internal bubble pressure - !! @param mv_in Mass of vapor in bubble + !> Subroutine that updates the conservative variables at the ghost points + !! @param pb_in Internal bubble pressure + !! @param mv_in Mass of vapor in bubble subroutine s_ibm_correct_state(q_cons_vf, q_prim_vf, pb_in, mv_in) - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: q_cons_vf !< Primitive Variables - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: q_prim_vf !< Primitive Variables - - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), optional, intent(INOUT) :: pb_in, mv_in - - integer :: i, j, k, l, q, r!< Iterator variables - integer :: patch_id !< Patch ID of ghost point - real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables - real(wp), dimension(2) :: Re_K - real(wp) :: G_K - real(wp) :: qv_K - - real(wp) :: pres_IP - real(wp), dimension(3) :: vel_IP, vel_norm_IP - real(wp) :: c_IP + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Primitive Variables + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive Variables + real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), optional, intent(inout) :: pb_in, mv_in + integer :: i, j, k, l, q, r !< Iterator variables + integer :: patch_id !< Patch ID of ghost point + real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables + real(wp), dimension(2) :: Re_K + real(wp) :: G_K + real(wp) :: qv_K + real(wp) :: pres_IP + real(wp), dimension(3) :: vel_IP, vel_norm_IP + real(wp) :: c_IP #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: Gs - real(wp), dimension(3) :: alpha_rho_IP, alpha_IP - real(wp), dimension(3) :: r_IP, v_IP, pb_IP, mv_IP + real(wp), dimension(3) :: Gs + real(wp), dimension(3) :: alpha_rho_IP, alpha_IP + real(wp), dimension(3) :: r_IP, v_IP, pb_IP, mv_IP real(wp), dimension(18) :: nmom_IP real(wp), dimension(12) :: presb_IP, massv_IP #:else real(wp), dimension(num_fluids) :: Gs real(wp), dimension(num_fluids) :: alpha_rho_IP, alpha_IP - real(wp), dimension(nb) :: r_IP, v_IP, pb_IP, mv_IP - real(wp), dimension(nb*nmom) :: nmom_IP - real(wp), dimension(nb*nnode) :: presb_IP, massv_IP + real(wp), dimension(nb) :: r_IP, v_IP, pb_IP, mv_IP + real(wp), dimension(nb*nmom) :: nmom_IP + real(wp), dimension(nb*nnode) :: presb_IP, massv_IP #:endif !! Primitive variables at the image point associated with a ghost point, !! interpolated from surrounding fluid cells. @@ -185,14 +160,13 @@ contains real(wp), dimension(3) :: vel_g !< Velocity of GP real(wp), dimension(3) :: radial_vector !< vector from centroid to ghost point real(wp), dimension(3) :: rotation_velocity !< speed of the ghost point due to rotation - - real(wp) :: nbub - real(wp) :: buf - type(ghost_point) :: gp - type(ghost_point) :: innerp + real(wp) :: nbub + real(wp) :: buf + type(ghost_point) :: gp + type(ghost_point) :: innerp ! set the Moving IBM interior conservative variables - $:GPU_PARALLEL_LOOP(private='[i,j,k,patch_id,rho]', copyin='[E_idx,momxb]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, patch_id, rho]', copyin='[E_idx, momxb]', collapse=3) do l = 0, p do k = 0, n do j = 0, m @@ -216,9 +190,10 @@ contains $:END_GPU_PARALLEL_LOOP() if (num_gps > 0) then - $:GPU_PARALLEL_LOOP(private='[i,physical_loc,dyn_pres,alpha_rho_IP, alpha_IP,pres_IP,vel_IP,vel_g,vel_norm_IP,r_IP, v_IP,pb_IP,mv_IP,nmom_IP,presb_IP,massv_IP,rho, gamma,pi_inf,Re_K,G_K,Gs,gp,innerp,norm,buf, radial_vector, rotation_velocity, j,k,l,q,qv_K,c_IP,nbub,patch_id]') + $:GPU_PARALLEL_LOOP(private='[i, physical_loc, dyn_pres, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, vel_g, vel_norm_IP, & + & r_IP, v_IP, pb_IP, mv_IP, nmom_IP, presb_IP, massv_IP, rho, gamma, pi_inf, Re_K, G_K, Gs, gp, innerp, norm, buf, & + & radial_vector, rotation_velocity, j, k, l, q, qv_K, c_IP, nbub, patch_id]') do i = 1, num_gps - gp = ghost_points(i) j = gp%loc(1) k = gp%loc(2) @@ -232,22 +207,18 @@ contains physical_loc = [x_cc(j), y_cc(k), 0._wp] end if - !Interpolate primitive variables at image point associated w/ GP + ! Interpolate primitive variables at image point associated w/ GP if (bubbles_euler .and. .not. qbmm) then - call s_interpolate_image_point(q_prim_vf, gp, & - alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, & - r_IP, v_IP, pb_IP, mv_IP) + call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & + & pb_IP, mv_IP) else if (qbmm .and. polytropic) then - call s_interpolate_image_point(q_prim_vf, gp, & - alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, & - r_IP, v_IP, pb_IP, mv_IP, nmom_IP) + call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & + & pb_IP, mv_IP, nmom_IP) else if (qbmm .and. .not. polytropic) then - call s_interpolate_image_point(q_prim_vf, gp, & - alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, & - r_IP, v_IP, pb_IP, mv_IP, nmom_IP, pb_in, mv_in, presb_IP, massv_IP) + call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & + & pb_IP, mv_IP, nmom_IP, pb_in, mv_in, presb_IP, massv_IP) else - call s_interpolate_image_point(q_prim_vf, gp, & - alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP) + call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP) end if dyn_pres = 0._wp @@ -270,19 +241,21 @@ contains q_prim_vf(E_idx)%sf(j, k, l) = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, num_fluids - ! Se the pressure inside a moving immersed boundary based upon the pressure of the image point. acceleration, and normal vector direction - q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, l) + pres_IP/(1._wp - 2._wp*abs(gp%levelset*alpha_rho_IP(q)/pres_IP)*dot_product(patch_ib(patch_id)%force/patch_ib(patch_id)%mass, gp%levelset_norm)) + ! Se the pressure inside a moving immersed boundary based upon the pressure of the image point. + ! acceleration, and normal vector direction + q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, & + & l) + pres_IP/(1._wp - 2._wp*abs(gp%levelset*alpha_rho_IP(q)/pres_IP) & + & *dot_product(patch_ib(patch_id)%force/patch_ib(patch_id)%mass, gp%levelset_norm)) end do end if if (model_eqns /= 4) then ! If in simulation, use acc mixture subroutines if (elasticity) then - call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, & - alpha_rho_IP, Re_K, G_K, Gs) + call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, alpha_rho_IP, Re_K, & + & G_K, Gs) else - call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, & - alpha_rho_IP, Re_K) + call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, alpha_rho_IP, Re_K) end if end if @@ -295,9 +268,10 @@ contains vel_g = vel_IP - vel_norm_IP if (patch_ib(patch_id)%moving_ibm /= 0) then ! compute the linear velocity of the ghost point due to rotation - radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, & - patch_ib(patch_id)%y_centroid, patch_ib(patch_id)%z_centroid] - call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), radial_vector, rotation_velocity) + radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, patch_ib(patch_id)%y_centroid, & + & patch_ib(patch_id)%z_centroid] + call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), & + & radial_vector, rotation_velocity) ! add only the component of the IB's motion that is normal to the surface vel_g = vel_g + sum((patch_ib(patch_id)%vel + rotation_velocity)*norm)*norm @@ -308,10 +282,12 @@ contains vel_g = 0._wp else ! get the vector that points from the centroid to the ghost - radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, & - patch_ib(patch_id)%y_centroid, patch_ib(patch_id)%z_centroid] - ! convert the angular velocity from the inertial reference frame to the fluids frame, then convert to linear velocity - call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), radial_vector, rotation_velocity) + radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, patch_ib(patch_id)%y_centroid, & + & patch_ib(patch_id)%z_centroid] + ! convert the angular velocity from the inertial reference frame to the fluids frame, then convert to linear + ! velocity + call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), & + & radial_vector, rotation_velocity) do q = 1, 3 ! if mibm is 1 or 2, then the boundary may be moving vel_g(q) = patch_ib(patch_id)%vel(q) ! add the linear velocity @@ -324,8 +300,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = momxb, momxe q_cons_vf(q)%sf(j, k, l) = rho*vel_g(q - momxb + 1) - dyn_pres = dyn_pres + q_cons_vf(q)%sf(j, k, l)* & - vel_g(q - momxb + 1)/2._wp + dyn_pres = dyn_pres + q_cons_vf(q)%sf(j, k, l)*vel_g(q - momxb + 1)/2._wp end do ! Set continuity and adv vars @@ -363,7 +338,6 @@ contains end if if (qbmm) then - nbub = nmom_IP(1) $:GPU_LOOP(parallelism='[seq]') do q = 1, nb*nmom @@ -390,40 +364,34 @@ contains if (model_eqns == 3) then $:GPU_LOOP(parallelism='[seq]') do q = intxb, intxe - q_cons_vf(q)%sf(j, k, l) = alpha_IP(q - intxb + 1)*(gammas(q - intxb + 1)*pres_IP & - + pi_infs(q - intxb + 1)) + q_cons_vf(q)%sf(j, k, l) = alpha_IP(q - intxb + 1)*(gammas(q - intxb + 1)*pres_IP + pi_infs(q - intxb + 1)) end do end if end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_ibm_correct_state - - !> Function that computes the image points for each ghost point - !! @param ghost_points_in Ghost Points + !> Function that computes the image points for each ghost point + !! @param ghost_points_in Ghost Points impure subroutine s_compute_image_points(ghost_points_in) - - type(ghost_point), dimension(num_gps), intent(INOUT) :: ghost_points_in - - real(wp) :: dist - real(wp), dimension(3) :: norm - real(wp), dimension(3) :: physical_loc - real(wp) :: temp_loc - real(wp), pointer, dimension(:) :: s_cc => null() - integer :: bound - type(ghost_point) :: gp - - integer :: q, dim !< Iterator variables - integer :: i, j, k, l !< Location indexes - integer :: patch_id !< IB Patch ID - integer :: dir - integer :: index - logical :: bounds_error + type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in + real(wp) :: dist + real(wp), dimension(3) :: norm + real(wp), dimension(3) :: physical_loc + real(wp) :: temp_loc + real(wp), pointer, dimension(:) :: s_cc => null() + integer :: bound + type(ghost_point) :: gp + integer :: q, dim !< Iterator variables + integer :: i, j, k, l !< Location indexes + integer :: patch_id !< IB Patch ID + integer :: dir + integer :: index + logical :: bounds_error bounds_error = .false. - $:GPU_PARALLEL_LOOP(private='[q,gp,i,j,k,physical_loc,patch_id,dist,norm,dim,bound,dir,index,temp_loc,s_cc]', copy='[bounds_error]') + $:GPU_PARALLEL_LOOP(private='[q, gp, i, j, k, physical_loc, patch_id, dist, norm, dim, bound, dir, index, temp_loc, s_cc]', copy='[bounds_error]') do q = 1, num_gps gp = ghost_points_in(q) i = gp%loc(1) @@ -445,12 +413,11 @@ contains ! Find the closest grid point to the image point do dim = 1, num_dims - ! s_cc points to the dim array we need if (dim == 1) then s_cc => x_cc bound = m + buff_size - 1 - elseif (dim == 2) then + else if (dim == 2) then s_cc => y_cc bound = n + buff_size - 1 else @@ -470,8 +437,7 @@ contains index = ghost_points_in(q)%loc(dim) temp_loc = ghost_points_in(q)%ip_loc(dim) - do while ((temp_loc < s_cc(index) & - .or. temp_loc > s_cc(index + 1)) .and. (.not. bounds_error)) + do while ((temp_loc < s_cc(index) .or. temp_loc > s_cc(index + 1)) .and. (.not. bounds_error)) index = index + dir if (index < -buff_size .or. index > bound) then #if !defined(MFC_OpenACC) && !defined(MFC_OpenMP) @@ -487,9 +453,13 @@ contains print *, "x: ", x_cc(-buff_size), " to: ", x_cc(m + buff_size - 1) print *, "y: ", y_cc(-buff_size), " to: ", y_cc(n + buff_size - 1) if (p /= 0) print *, "z: ", z_cc(-buff_size), " to: ", z_cc(p + buff_size - 1) - print *, "Image point is located approximately ", (ghost_points_in(q)%loc(dim) - ghost_points_in(q)%ip_loc(dim))/(s_cc(1) - s_cc(0)), " grid cells away" + print *, "Image point is located approximately ", & + & (ghost_points_in(q)%loc(dim) - ghost_points_in(q) & + & %ip_loc(dim))/(s_cc(1) - s_cc(0)), & + & " grid cells away" print *, "Levelset ", dist, " and Norm: ", norm(:) - print *, "A short term fix may include increasing buff_size further in m_helper_basic (currently set to a minimum of 10)" + print *, & + & "A short term fix may include increasing buff_size further in m_helper_basic (currently set to a minimum of 10)" #endif bounds_error = .true. end if @@ -507,24 +477,20 @@ contains $:END_GPU_PARALLEL_LOOP() if (bounds_error) error stop "Ghost Point and Image Point on Different Processors. Exiting" - end subroutine s_compute_image_points - - !> Subroutine that finds the number of ghost points, used for allocating - !! memory. + !> Subroutine that finds the number of ghost points, used for allocating memory. subroutine s_find_num_ghost_points(num_gps_out) - integer, intent(out) :: num_gps_out - - integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables - integer :: num_gps_local !< local copies of the gp count to support GPU compute - logical :: is_gp + integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables + integer :: num_gps_local !< local copies of the gp count to support GPU compute + logical :: is_gp num_gps_local = 0 gp_layers_z = gp_layers if (p == 0) gp_layers_z = 0 - $:GPU_PARALLEL_LOOP(private='[i,j,k,ii,jj,kk,is_gp]', copy='[num_gps_local]', firstprivate='[gp_layers,gp_layers_z]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, ii, jj, kk, is_gp]', copy='[num_gps_local]', firstprivate='[gp_layers, & + & gp_layers_z]', collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -553,25 +519,23 @@ contains $:END_GPU_PARALLEL_LOOP() num_gps_out = num_gps_local - end subroutine s_find_num_ghost_points - !> Function that finds the ghost points subroutine s_find_ghost_points(ghost_points_in) - - type(ghost_point), dimension(num_gps), intent(INOUT) :: ghost_points_in - integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables - integer :: xp, yp, zp !< periodicities - integer :: count, count_i, local_idx - integer :: patch_id, encoded_patch_id - logical :: is_gp + type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in + integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables + integer :: xp, yp, zp !< periodicities + integer :: count, count_i, local_idx + integer :: patch_id, encoded_patch_id + logical :: is_gp count = 0 count_i = 0 gp_layers_z = gp_layers if (p == 0) gp_layers_z = 0 - $:GPU_PARALLEL_LOOP(private='[i,j,k,ii,jj,kk,is_gp,local_idx,patch_id,encoded_patch_id,xp,yp,zp]', copyin='[count,count_i, x_domain, y_domain, z_domain]', firstprivate='[gp_layers,gp_layers_z]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, ii, jj, kk, is_gp, local_idx, patch_id, encoded_patch_id, xp, yp, zp]', & + & copyin='[count, count_i, x_domain, y_domain, z_domain]', firstprivate='[gp_layers, gp_layers_z]', collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -636,25 +600,21 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_find_ghost_points - - !> Function that computes the interpolation coefficients of image points + !> Function that computes the interpolation coefficients of image points subroutine s_compute_interpolation_coeffs(ghost_points_in) - - type(ghost_point), dimension(num_gps), intent(INOUT) :: ghost_points_in - - real(wp), dimension(2, 2, 2) :: dist - real(wp), dimension(2, 2, 2) :: alpha - real(wp), dimension(2, 2, 2) :: interp_coeffs - real(wp) :: buf - real(wp), dimension(2, 2, 2) :: eta - type(ghost_point) :: gp - integer :: q, i, j, k, ii, jj, kk !< Grid indexes and iterators - integer :: patch_id + type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in + real(wp), dimension(2, 2, 2) :: dist + real(wp), dimension(2, 2, 2) :: alpha + real(wp), dimension(2, 2, 2) :: interp_coeffs + real(wp) :: buf + real(wp), dimension(2, 2, 2) :: eta + type(ghost_point) :: gp + integer :: q, i, j, k, ii, jj, kk !< Grid indexes and iterators + integer :: patch_id logical is_cell_center - $:GPU_PARALLEL_LOOP(private='[q,i,j,k,ii,jj,kk,dist,buf,gp,interp_coeffs,eta,alpha,patch_id,is_cell_center]') + $:GPU_PARALLEL_LOOP(private='[q, i, j, k, ii, jj, kk, dist, buf, gp, interp_coeffs, eta, alpha, patch_id, is_cell_center]') do q = 1, num_gps gp = ghost_points_in(q) ! Get the interpolation points @@ -663,7 +623,7 @@ contains if (p /= 0) then k = gp%ip_grid(3) else - k = 0; + k = 0; end if ! get the distance to a cell in each direction @@ -672,15 +632,12 @@ contains do ii = 0, 1 do jj = 0, 1 if (p == 0) then - dist(1 + ii, 1 + jj, 1) = sqrt( & - (x_cc(i + ii) - gp%ip_loc(1))**2 + & - (y_cc(j + jj) - gp%ip_loc(2))**2) + dist(1 + ii, 1 + jj, 1) = sqrt((x_cc(i + ii) - gp%ip_loc(1))**2 + (y_cc(j + jj) - gp%ip_loc(2))**2) else do kk = 0, 1 - dist(1 + ii, 1 + jj, 1 + kk) = sqrt( & - (x_cc(i + ii) - gp%ip_loc(1))**2 + & - (y_cc(j + jj) - gp%ip_loc(2))**2 + & - (z_cc(k + kk) - gp%ip_loc(3))**2) + dist(1 + ii, 1 + jj, & + & 1 + kk) = sqrt((x_cc(i + ii) - gp%ip_loc(1))**2 + (y_cc(j + jj) - gp%ip_loc(2))**2 + (z_cc(k & + & + kk) - gp%ip_loc(3))**2) end do end if end do @@ -717,13 +674,13 @@ contains if (ib_markers%sf(i + 1, j + 1, k) /= 0) alpha(2, 2, 1) = 0._wp if (p == 0) then - eta(:, :, 1) = 1._wp/dist(:, :, 1)**2 - buf = sum(alpha(:, :, 1)*eta(:, :, 1)) + eta(:,:, 1) = 1._wp/dist(:,:, 1)**2 + buf = sum(alpha(:,:, 1)*eta(:,:, 1)) if (buf > 0._wp) then - interp_coeffs(:, :, 1) = alpha(:, :, 1)*eta(:, :, 1)/buf + interp_coeffs(:,:, 1) = alpha(:,:, 1)*eta(:,:, 1)/buf else - buf = sum(eta(:, :, 1)) - interp_coeffs(:, :, 1) = eta(:, :, 1)/buf + buf = sum(eta(:,:, 1)) + interp_coeffs(:,:, 1) = eta(:,:, 1)/buf end if else @@ -741,19 +698,17 @@ contains interp_coeffs = eta/buf end if end if - end if ghost_points_in(q)%interp_coeffs = interp_coeffs end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_compute_interpolation_coeffs - - !> Function that uses the interpolation coefficients and the current state - !! at the cell centers in order to estimate the state at the image point + !> Function that uses the interpolation coefficients and the current state at the cell centers in order to estimate the state at + !! the image point !! @param gp Ghost point data structure - !> @brief Interpolates primitive variables from the fluid domain to a ghost point's image point using bilinear or trilinear interpolation. + !> @brief Interpolates primitive variables from the fluid domain to a ghost point's image point using bilinear or trilinear + !! interpolation. !! @param alpha_rho_IP Partial density at image point !! @param alpha_IP Volume fraction at image point !! @param pres_IP Pressure at image point @@ -768,32 +723,26 @@ contains !! @param mv_in Mass of vapor in bubble array !! @param presb_IP Bubble node pressure at image point !! @param massv_IP Bubble node vapor mass at image point - subroutine s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, & - pres_IP, vel_IP, c_IP, r_IP, v_IP, pb_IP, & - mv_IP, nmom_IP, pb_in, mv_in, presb_IP, massv_IP) + subroutine s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, pb_IP, mv_IP, & + & nmom_IP, pb_in, mv_in, presb_IP, massv_IP) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), & - dimension(sys_size), & - intent(IN) :: q_prim_vf !< Primitive Variables - - real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(IN) :: pb_in, mv_in - - type(ghost_point), intent(IN) :: gp - real(wp), intent(INOUT) :: pres_IP - real(wp), dimension(3), intent(INOUT) :: vel_IP - real(wp), intent(INOUT) :: c_IP + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !< Primitive Variables + real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(in) :: pb_in, mv_in + type(ghost_point), intent(in) :: gp + real(wp), intent(inout) :: pres_IP + real(wp), dimension(3), intent(inout) :: vel_IP + real(wp), intent(inout) :: c_IP #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3), intent(INOUT) :: alpha_IP, alpha_rho_IP + real(wp), dimension(3), intent(inout) :: alpha_IP, alpha_rho_IP #:else - real(wp), dimension(num_fluids), intent(INOUT) :: alpha_IP, alpha_rho_IP + real(wp), dimension(num_fluids), intent(inout) :: alpha_IP, alpha_rho_IP #:endif - real(wp), optional, dimension(:), intent(INOUT) :: r_IP, v_IP, pb_IP, mv_IP - real(wp), optional, dimension(:), intent(INOUT) :: nmom_IP - real(wp), optional, dimension(:), intent(INOUT) :: presb_IP, massv_IP - - integer :: i, j, k, l, q !< Iterator variables - integer :: i1, i2, j1, j2, k1, k2 !< Iterator variables - real(wp) :: coeff + real(wp), optional, dimension(:), intent(inout) :: r_IP, v_IP, pb_IP, mv_IP + real(wp), optional, dimension(:), intent(inout) :: nmom_IP + real(wp), optional, dimension(:), intent(inout) :: presb_IP, massv_IP + integer :: i, j, k, l, q !< Iterator variables + integer :: i1, i2, j1, j2, k1, k2 !< Iterator variables + real(wp) :: coeff i1 = gp%ip_grid(1); i2 = i1 + 1 j1 = gp%ip_grid(2); j2 = j1 + 1 @@ -834,24 +783,19 @@ contains do j = j1, j2 $:GPU_LOOP(parallelism='[seq]') do k = k1, k2 - coeff = gp%interp_coeffs(i - i1 + 1, j - j1 + 1, k - k1 + 1) - pres_IP = pres_IP + coeff* & - q_prim_vf(E_idx)%sf(i, j, k) + pres_IP = pres_IP + coeff*q_prim_vf(E_idx)%sf(i, j, k) $:GPU_LOOP(parallelism='[seq]') do q = momxb, momxe - vel_IP(q + 1 - momxb) = vel_IP(q + 1 - momxb) + coeff* & - q_prim_vf(q)%sf(i, j, k) + vel_IP(q + 1 - momxb) = vel_IP(q + 1 - momxb) + coeff*q_prim_vf(q)%sf(i, j, k) end do $:GPU_LOOP(parallelism='[seq]') do l = contxb, contxe - alpha_rho_IP(l) = alpha_rho_IP(l) + coeff* & - q_prim_vf(l)%sf(i, j, k) - alpha_IP(l) = alpha_IP(l) + coeff* & - q_prim_vf(advxb + l - 1)%sf(i, j, k) + alpha_rho_IP(l) = alpha_rho_IP(l) + coeff*q_prim_vf(l)%sf(i, j, k) + alpha_IP(l) = alpha_IP(l) + coeff*q_prim_vf(advxb + l - 1)%sf(i, j, k) end do if (surface_tension) then @@ -880,38 +824,32 @@ contains if (.not. polytropic) then do q = 1, nb do l = 1, nnode - presb_IP((q - 1)*nnode + l) = presb_IP((q - 1)*nnode + l) + & - coeff*real(pb_in(i, j, k, l, q), kind=wp) - massv_IP((q - 1)*nnode + l) = massv_IP((q - 1)*nnode + l) + & - coeff*real(mv_in(i, j, k, l, q), kind=wp) + presb_IP((q - 1)*nnode + l) = presb_IP((q - 1)*nnode + l) + coeff*real(pb_in(i, j, k, l, q), & + & kind=wp) + massv_IP((q - 1)*nnode + l) = massv_IP((q - 1)*nnode + l) + coeff*real(mv_in(i, j, k, l, q), & + & kind=wp) end do end do end if - end if - end do end do end do - end subroutine s_interpolate_image_point - !> Resets the current indexes of immersed boundaries and replaces them after updating !> the position of each moving immersed boundary impure subroutine s_update_mib(num_ibs) - integer, intent(in) :: num_ibs - - integer :: i, j, k, ierr, z_gp_layers + integer :: i, j, k, ierr, z_gp_layers call nvtxStartRange("UPDATE-MIBM") ! Clears the existing immersed boundary indices z_gp_layers = 0; if (p /= 0) z_gp_layers = gp_layers + 1 - $:GPU_PARALLEL_LOOP(private='[i,j,k]') + $:GPU_PARALLEL_LOOP(private='[i, j, k]') do i = -gp_layers - 1, m + gp_layers + 1; do j = -gp_layers - 1, n + gp_layers + 1; do k = -z_gp_layers, p + z_gp_layers - ib_markers%sf(i, j, k) = 0._wp - end do; end do; end do + ib_markers%sf(i, j, k) = 0._wp + end do; end do; end do $:END_GPU_PARALLEL_LOOP() ! recalulcate the rotation matrix based upon the new angles @@ -941,23 +879,20 @@ contains call nvtxEndRange call nvtxEndRange - end subroutine s_update_mib - !> @brief Computes pressure and viscous forces and torques on immersed bodies via a volume integration method. subroutine s_compute_ib_forces(q_prim_vf, fluid_pp) - ! real(wp), dimension(idwbuff(1)%beg:idwbuff(1)%end, & ! idwbuff(2)%beg:idwbuff(2)%end, & ! idwbuff(3)%beg:idwbuff(3)%end), intent(in) :: pressure - type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf type(physical_parameters), dimension(1:num_fluids), intent(in) :: fluid_pp - - integer :: gp_id, i, j, k, l, q, ib_idx, fluid_idx - real(wp), dimension(num_ibs, 3) :: forces, torques - real(wp), dimension(1:3, 1:3) :: viscous_stress_div, viscous_stress_div_1, viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations + integer :: gp_id, i, j, k, l, q, ib_idx, fluid_idx + real(wp), dimension(num_ibs, 3) :: forces, torques + real(wp), dimension(1:3, 1:3) :: viscous_stress_div, viscous_stress_div_1, & + & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations real(wp), dimension(1:3) :: local_force_contribution, radial_vector, local_torque_contribution, vel - real(wp) :: cell_volume, dx, dy, dz, dynamic_viscosity + real(wp) :: cell_volume, dx, dy, dz, dynamic_viscosity #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: dynamic_viscosities #:else @@ -979,7 +914,9 @@ contains end do end if - $:GPU_PARALLEL_LOOP(private='[ib_idx,fluid_idx, radial_vector,local_force_contribution,cell_volume,local_torque_contribution, dynamic_viscosity, viscous_stress_div, viscous_stress_div_1, viscous_stress_div_2, dx, dy, dz]', copy='[forces,torques]', copyin='[ib_markers,patch_ib,dynamic_viscosities]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[ib_idx, fluid_idx, radial_vector, local_force_contribution, cell_volume, & + & local_torque_contribution, dynamic_viscosity, viscous_stress_div, viscous_stress_div_1, viscous_stress_div_2, dx, dy, & + & dz]', copy='[forces, torques]', copyin='[ib_markers, patch_ib, dynamic_viscosities]', collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -987,23 +924,30 @@ contains if (ib_idx /= 0) then ! get the vector pointing to the grid cell from the IB centroid if (num_dims == 3) then - radial_vector = [x_cc(i), y_cc(j), z_cc(k)] - [patch_ib(ib_idx)%x_centroid, patch_ib(ib_idx)%y_centroid, patch_ib(ib_idx)%z_centroid] + radial_vector = [x_cc(i), y_cc(j), z_cc(k)] - [patch_ib(ib_idx)%x_centroid, & + & patch_ib(ib_idx)%y_centroid, patch_ib(ib_idx)%z_centroid] else - radial_vector = [x_cc(i), y_cc(j), 0._wp] - [patch_ib(ib_idx)%x_centroid, patch_ib(ib_idx)%y_centroid, 0._wp] + radial_vector = [x_cc(i), y_cc(j), 0._wp] - [patch_ib(ib_idx)%x_centroid, & + & patch_ib(ib_idx)%y_centroid, 0._wp] end if dx = x_cc(i + 1) - x_cc(i) dy = y_cc(j + 1) - y_cc(j) local_force_contribution(:) = 0._wp do fluid_idx = 0, num_fluids - 1 - ! Get the pressure contribution to force via a finite difference to compute the 2D components of the gradient of the pressure and cell volume - local_force_contribution(1) = local_force_contribution(1) - (q_prim_vf(E_idx + fluid_idx)%sf(i + 1, j, k) - q_prim_vf(E_idx + fluid_idx)%sf(i - 1, j, k))/(2._wp*dx) ! force is the negative pressure gradient - local_force_contribution(2) = local_force_contribution(2) - (q_prim_vf(E_idx + fluid_idx)%sf(i, j + 1, k) - q_prim_vf(E_idx + fluid_idx)%sf(i, j - 1, k))/(2._wp*dy) + ! Get the pressure contribution to force via a finite difference to compute the 2D components of the + ! gradient of the pressure and cell volume + local_force_contribution(1) = local_force_contribution(1) - (q_prim_vf(E_idx + fluid_idx)%sf(i + 1, & + & j, k) - q_prim_vf(E_idx + fluid_idx)%sf(i - 1, j, & + & k))/(2._wp*dx) ! force is the negative pressure gradient + local_force_contribution(2) = local_force_contribution(2) - (q_prim_vf(E_idx + fluid_idx)%sf(i, & + & j + 1, k) - q_prim_vf(E_idx + fluid_idx)%sf(i, j - 1, k))/(2._wp*dy) cell_volume = abs(dx*dy) ! add the 3D component of the pressure gradient, if we are working in 3 dimensions if (num_dims == 3) then dz = z_cc(k + 1) - z_cc(k) - local_force_contribution(3) = local_force_contribution(3) - (q_prim_vf(E_idx + fluid_idx)%sf(i, j, k + 1) - q_prim_vf(E_idx + fluid_idx)%sf(i, j, k - 1))/(2._wp*dz) + local_force_contribution(3) = local_force_contribution(3) - (q_prim_vf(E_idx + fluid_idx)%sf(i, & + & j, k + 1) - q_prim_vf(E_idx + fluid_idx)%sf(i, j, k - 1))/(2._wp*dz) cell_volume = abs(cell_volume*dz) end if end do @@ -1014,27 +958,35 @@ contains dynamic_viscosity = 0._wp do fluid_idx = 1, num_fluids ! local dynamic viscosity is the dynamic viscosity of the fluid times alpha of the fluid - dynamic_viscosity = dynamic_viscosity + (q_prim_vf(fluid_idx + advxb - 1)%sf(i, j, k)*dynamic_viscosities(fluid_idx)) + dynamic_viscosity = dynamic_viscosity + (q_prim_vf(fluid_idx + advxb - 1)%sf(i, j, & + & k)*dynamic_viscosities(fluid_idx)) end do ! get the linear force components first call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i - 1, j, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i + 1, j, k) - viscous_stress_div(1, 1:3) = (viscous_stress_div_2(1, 1:3) - viscous_stress_div_1(1, 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor - local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(1, 1:3) ! add the x components of the divergence to the force + viscous_stress_div(1, 1:3) = (viscous_stress_div_2(1, 1:3) - viscous_stress_div_1(1, & + & 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor + local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(1, & + & 1:3) ! add the x components of the divergence to the force call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j - 1, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j + 1, k) - viscous_stress_div(2, 1:3) = (viscous_stress_div_2(2, 1:3) - viscous_stress_div_1(2, 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor - local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(2, 1:3) ! add the y components of the divergence to the force + viscous_stress_div(2, 1:3) = (viscous_stress_div_2(2, 1:3) - viscous_stress_div_1(2, & + & 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor + local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(2, & + & 1:3) ! add the y components of the divergence to the force if (num_dims == 3) then - call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j, k - 1) - call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j, k + 1) - viscous_stress_div(3, 1:3) = (viscous_stress_div_2(3, 1:3) - viscous_stress_div_1(3, 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor - local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(3, 1:3) ! add the z components of the divergence to the force + call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j, & + & k - 1) + call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j, & + & k + 1) + viscous_stress_div(3, 1:3) = (viscous_stress_div_2(3, 1:3) - viscous_stress_div_1(3, & + & 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor + local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(3, & + & 1:3) ! add the z components of the divergence to the force end if - end if call s_cross_product(radial_vector, local_force_contribution, local_torque_contribution) @@ -1071,40 +1023,31 @@ contains ! apply the summed forces do i = 1, num_ibs - patch_ib(i)%force(:) = forces(i, :) - patch_ib(i)%torque(:) = matmul(patch_ib(i)%rotation_matrix_inverse, torques(i, :)) ! torques must be converted to the local coordinates of the IB + patch_ib(i)%force(:) = forces(i,:) + patch_ib(i)%torque(:) = matmul(patch_ib(i)%rotation_matrix_inverse, torques(i, & + & :)) ! torques must be converted to the local coordinates of the IB end do call nvtxEndRange - end subroutine s_compute_ib_forces - !> Subroutine to deallocate memory reserved for the IBM module impure subroutine s_finalize_ibm_module() - @:DEALLOCATE(ib_markers%sf) if (allocated(airfoil_grid_u)) then @:DEALLOCATE(airfoil_grid_u) @:DEALLOCATE(airfoil_grid_l) end if - end subroutine s_finalize_ibm_module - !> Computes the center of mass for IB patch types where we are unable to determine their center of mass analytically. !> These patches include things like NACA airfoils and STL models subroutine s_compute_centroid_offset(ib_marker) - - integer, intent(in) :: ib_marker - - integer :: i, j, k, num_cells, num_cells_local + integer, intent(in) :: ib_marker + integer :: i, j, k, num_cells, num_cells_local real(wp), dimension(1:3) :: center_of_mass, center_of_mass_local ! Offset only needs to be computes for specific geometries - if (patch_ib(ib_marker)%geometry == 4 .or. & - patch_ib(ib_marker)%geometry == 5 .or. & - patch_ib(ib_marker)%geometry == 11 .or. & - patch_ib(ib_marker)%geometry == 12) then - + if (patch_ib(ib_marker)%geometry == 4 .or. patch_ib(ib_marker)%geometry == 5 .or. patch_ib(ib_marker) & + & %geometry == 11 .or. patch_ib(ib_marker)%geometry == 12) then center_of_mass_local = [0._wp, 0._wp, 0._wp] num_cells_local = 0 @@ -1133,31 +1076,29 @@ contains return end if - ! assign the centroid offset as a vector pointing from the true COM to the "centroid" in the input file and replace the current centroid - patch_ib(ib_marker)%centroid_offset = [patch_ib(ib_marker)%x_centroid, patch_ib(ib_marker)%y_centroid, patch_ib(ib_marker)%z_centroid] & - - center_of_mass + ! assign the centroid offset as a vector pointing from the true COM to the "centroid" in the input file and replace the + ! current centroid + patch_ib(ib_marker)%centroid_offset = [patch_ib(ib_marker)%x_centroid, patch_ib(ib_marker)%y_centroid, & + & patch_ib(ib_marker)%z_centroid] - center_of_mass patch_ib(ib_marker)%x_centroid = center_of_mass(1) patch_ib(ib_marker)%y_centroid = center_of_mass(2) patch_ib(ib_marker)%z_centroid = center_of_mass(3) ! rotate the centroid offset back into the local coords of the IB - patch_ib(ib_marker)%centroid_offset = matmul(patch_ib(ib_marker)%rotation_matrix_inverse, patch_ib(ib_marker)%centroid_offset) + patch_ib(ib_marker)%centroid_offset = matmul(patch_ib(ib_marker)%rotation_matrix_inverse, & + & patch_ib(ib_marker)%centroid_offset) else patch_ib(ib_marker)%centroid_offset(:) = [0._wp, 0._wp, 0._wp] end if - end subroutine s_compute_centroid_offset - - !> Computes the moment of inertia for an immersed boundary - !! @param ib_marker Immersed boundary marker index + !> Computes the moment of inertia for an immersed boundary + !! @param ib_marker Immersed boundary marker index subroutine s_compute_moment_of_inertia(ib_marker, axis) - real(wp), dimension(3), intent(in) :: axis !< the axis about which we compute the moment. Only required in 3D. - integer, intent(in) :: ib_marker - - real(wp) :: moment, distance_to_axis, cell_volume - real(wp), dimension(3) :: position, closest_point_along_axis, vector_to_axis, normal_axis - integer :: i, j, k, count + integer, intent(in) :: ib_marker + real(wp) :: moment, distance_to_axis, cell_volume + real(wp), dimension(3) :: position, closest_point_along_axis, vector_to_axis, normal_axis + integer :: i, j, k, count if (p == 0) then normal_axis = [0, 0, 1] @@ -1172,22 +1113,25 @@ contains ! if the IB is in 2D or a 3D sphere, we can compute this exactly if (patch_ib(ib_marker)%geometry == 2) then ! circle patch_ib(ib_marker)%moment = 0.5_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%radius)**2 - elseif (patch_ib(ib_marker)%geometry == 3) then ! rectangle - patch_ib(ib_marker)%moment = patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker)%length_y**2)/6._wp - elseif (patch_ib(ib_marker)%geometry == 6) then ! ellipse - patch_ib(ib_marker)%moment = 0.0625_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker)%length_y**2) - elseif (patch_ib(ib_marker)%geometry == 8) then ! sphere + else if (patch_ib(ib_marker)%geometry == 3) then ! rectangle + patch_ib(ib_marker)%moment = patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker) & + & %length_y**2)/6._wp + else if (patch_ib(ib_marker)%geometry == 6) then ! ellipse + patch_ib(ib_marker)%moment = 0.0625_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker) & + & %length_y**2) + else if (patch_ib(ib_marker)%geometry == 8) then ! sphere patch_ib(ib_marker)%moment = 0.4*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%radius)**2 - else ! we do not have an analytic moment of inertia calculation and need to approximate it directly via a sum count = 0 moment = 0._wp - cell_volume = (x_cc(1) - x_cc(0))*(y_cc(1) - y_cc(0)) ! computed without grid stretching. Update in the loop to perform with stretching + cell_volume = (x_cc(1) - x_cc(0))*(y_cc(1) - y_cc(0)) & + & ! computed without grid stretching. Update in the loop to perform with stretching if (p /= 0) then cell_volume = cell_volume*(z_cc(1) - z_cc(0)) end if - $:GPU_PARALLEL_LOOP(private='[position,closest_point_along_axis,vector_to_axis,distance_to_axis]', copy='[moment,count]', copyin='[ib_marker,cell_volume,normal_axis]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[position, closest_point_along_axis, vector_to_axis, distance_to_axis]', copy='[moment, & + & count]', copyin='[ib_marker, cell_volume, normal_axis]', collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -1197,9 +1141,11 @@ contains ! get the position in local coordinates so that the axis passes through 0, 0, 0 if (p == 0) then - position = [x_cc(i), y_cc(j), 0._wp] - [patch_ib(ib_marker)%x_centroid, patch_ib(ib_marker)%y_centroid, 0._wp] + position = [x_cc(i), y_cc(j), 0._wp] - [patch_ib(ib_marker)%x_centroid, & + & patch_ib(ib_marker)%y_centroid, 0._wp] else - position = [x_cc(i), y_cc(j), z_cc(k)] - [patch_ib(ib_marker)%x_centroid, patch_ib(ib_marker)%y_centroid, patch_ib(ib_marker)%z_centroid] + position = [x_cc(i), y_cc(j), z_cc(k)] - [patch_ib(ib_marker)%x_centroid, & + & patch_ib(ib_marker)%y_centroid, patch_ib(ib_marker)%z_centroid] end if ! project the position along the axis to find the closest distance to the rotation axis @@ -1220,12 +1166,9 @@ contains patch_ib(ib_marker)%moment = moment*patch_ib(ib_marker)%mass/(count*cell_volume) $:GPU_UPDATE(device='[patch_ib(ib_marker)%moment]') end if - end subroutine s_compute_moment_of_inertia - !> @brief Checks for periodic boundary conditions in all directions, and if so, moves patch location if it left the domain subroutine s_wrap_periodic_ibs() - integer :: patch_id do patch_id = 1, num_ibs @@ -1236,10 +1179,12 @@ contains ! check if the boundary has left the domain, and then correct if (patch_ib(patch_id)%${X}$_centroid < ${X}$_domain%beg) then ! if the boundary exited "left", wrap it back around to the "right" - patch_ib(patch_id)%${X}$_centroid = patch_ib(patch_id)%${X}$_centroid + (${X}$_domain%end - ${X}$_domain%beg) + patch_ib(patch_id)%${X}$_centroid = patch_ib(patch_id)%${X}$_centroid + (${X}$_domain%end & + & - ${X}$_domain%beg) else if (patch_ib(patch_id)%${X}$_centroid > ${X}$_domain%end) then ! if the boundary exited "right", wrap it back around to the "left" - patch_ib(patch_id)%${X}$_centroid = patch_ib(patch_id)%${X}$_centroid - (${X}$_domain%end - ${X}$_domain%beg) + patch_ib(patch_id)%${X}$_centroid = patch_ib(patch_id)%${X}$_centroid - (${X}$_domain%end & + & - ${X}$_domain%beg) end if end if #:endfor @@ -1258,18 +1203,15 @@ contains end if end if end do - end subroutine s_wrap_periodic_ibs - !> @brief Computes the cross product c = a x b of two 3D vectors. subroutine s_cross_product(a, b, c) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: a(3), b(3) + real(wp), intent(in) :: a(3), b(3) real(wp), intent(out) :: c(3) c(1) = a(2)*b(3) - a(3)*b(2) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) end subroutine s_cross_product - end module m_ibm diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index 78956ef803..6aa1dd6835 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -7,7 +7,6 @@ !> @brief Iterative ghost rasterization (IGR) for sharp immersed boundary treatment module m_igr - use m_derived_types !< Definitions of the derived types use m_global_parameters @@ -22,32 +21,28 @@ module m_igr implicit none - private; public :: s_initialize_igr_module, & - s_igr_iterative_solve, & - s_igr_riemann_solver, & - s_igr_sigma_x, & - s_igr_flux_add, & - s_finalize_igr_module + private; public :: s_initialize_igr_module, s_igr_iterative_solve, s_igr_riemann_solver, s_igr_sigma_x, s_igr_flux_add, & + & s_finalize_igr_module -!> @cond + !> @cond #ifdef __NVCOMPILER_GPU_UNIFIED_MEM - integer, dimension(3) :: nv_uvm_temp_on_gpu - real(wp), pointer, contiguous, dimension(:, :, :) :: jac, jac_rhs, jac_old - real(wp), allocatable, dimension(:, :, :), pinned, target :: jac_host - real(wp), allocatable, dimension(:, :, :), pinned, target :: jac_rhs_host - real(wp), allocatable, dimension(:, :, :), pinned, target :: jac_old_host + integer, dimension(3) :: nv_uvm_temp_on_gpu + real(wp), pointer, contiguous, dimension(:,:,:) :: jac, jac_rhs, jac_old + real(wp), allocatable, dimension(:,:,:), pinned, target :: jac_host + real(wp), allocatable, dimension(:,:,:), pinned, target :: jac_rhs_host + real(wp), allocatable, dimension(:,:,:), pinned, target :: jac_old_host #else -!> @endcond - real(wp), allocatable, target, dimension(:, :, :) :: jac - real(wp), allocatable, dimension(:, :, :) :: jac_rhs, jac_old + !> @endcond + real(wp), allocatable, target, dimension(:,:,:) :: jac + real(wp), allocatable, dimension(:,:,:) :: jac_rhs, jac_old $:GPU_DECLARE(create='[jac, jac_rhs, jac_old]') -!> @cond + !> @cond #endif -!> @endcond + !> @endcond type(scalar_field), dimension(1) :: jac_sf $:GPU_DECLARE(create='[jac_sf]') - real(wp), allocatable, dimension(:, :) :: Res_igr + real(wp), allocatable, dimension(:,:) :: Res_igr $:GPU_DECLARE(create='[Res_igr]') real(wp) :: alf_igr @@ -65,64 +60,22 @@ module m_igr integer, parameter :: vidxe = 3 #if defined(MFC_OpenMP) - real(wp) :: coeff_L(-1:3) = [ & - -3._wp/60._wp, & ! Index -1 - 27._wp/60._wp, & ! Index 0 - 47._wp/60._wp, & ! Index 1 - -13._wp/60._wp, & ! Index 2 - 2._wp/60._wp & ! Index 3 - ] - - real(wp) :: coeff_R(-2:2) = [ & - 2._wp/60._wp, & ! Index -2 - -13._wp/60._wp, & ! Index -1 - 47._wp/60._wp, & ! Index 0 - 27._wp/60._wp, & ! Index 1 - -3._wp/60._wp & ! Index 2 - ] + real(wp) :: coeff_L(-1:3) = [-3._wp/60._wp, 27._wp/60._wp, 47._wp/60._wp, -13._wp/60._wp, 2._wp/60._wp] + real(wp) :: coeff_R(-2:2) = [2._wp/60._wp, -13._wp/60._wp, 47._wp/60._wp, 27._wp/60._wp, -3._wp/60._wp] #else - real(wp), parameter :: coeff_L(-1:3) = [ & - -3._wp/60._wp, & ! Index -1 - 27._wp/60._wp, & ! Index 0 - 47._wp/60._wp, & ! Index 1 - -13._wp/60._wp, & ! Index 2 - 2._wp/60._wp & ! Index 3 - ] - - real(wp), parameter :: coeff_R(-2:2) = [ & - 2._wp/60._wp, & ! Index -2 - -13._wp/60._wp, & ! Index -1 - 47._wp/60._wp, & ! Index 0 - 27._wp/60._wp, & ! Index 1 - -3._wp/60._wp & ! Index 2 - ] + real(wp), parameter :: coeff_L(-1:3) = [-3._wp/60._wp, 27._wp/60._wp, 47._wp/60._wp, -13._wp/60._wp, 2._wp/60._wp] + real(wp), parameter :: coeff_R(-2:2) = [2._wp/60._wp, -13._wp/60._wp, 47._wp/60._wp, 27._wp/60._wp, -3._wp/60._wp] #endif #:elif igr_order == 3 integer, parameter :: vidxb = -1 integer, parameter :: vidxe = 2 #if defined(MFC_OpenMP) - real(wp) :: coeff_L(0:2) = [ & - 2._wp/6._wp, & ! Index 0 - 5._wp/6._wp, & ! Index 1 - -1._wp/6._wp & ! Index 2 - ] - real(wp) :: coeff_R(-1:1) = [ & - -1._wp/6._wp, & ! Index -1 - 5._wp/6._wp, & ! Index 0 - 2._wp/6._wp & ! Index 1 - ] + real(wp) :: coeff_L(0:2) = [2._wp/6._wp, 5._wp/6._wp, -1._wp/6._wp] + real(wp) :: coeff_R(-1:1) = [-1._wp/6._wp, 5._wp/6._wp, 2._wp/6._wp] #else - real(wp), parameter :: coeff_L(0:2) = [ & - 2._wp/6._wp, & ! Index 0 - 5._wp/6._wp, & ! Index 1 - -1._wp/6._wp & ! Index 2 - ] - real(wp), parameter :: coeff_R(-1:1) = [ & - -1._wp/6._wp, & ! Index -1 - 5._wp/6._wp, & ! Index 0 - 2._wp/6._wp & ! Index 1 - ] + real(wp), parameter :: coeff_L(0:2) = [2._wp/6._wp, 5._wp/6._wp, -1._wp/6._wp] + real(wp), parameter :: coeff_R(-1:1) = [-1._wp/6._wp, 5._wp/6._wp, 2._wp/6._wp] #endif #:endif @@ -132,12 +85,11 @@ module m_igr #:endif integer(kind=8) :: i, j, k, l, q, r - contains - !> @brief Allocates and initializes arrays, coefficients, and GPU data structures for the implicit gradient reconstruction module. + !> @brief Allocates and initializes arrays, coefficients, and GPU data structures for the implicit gradient reconstruction + !! module. subroutine s_initialize_igr_module() - if (viscous) then @:ALLOCATE(Res_igr(1:2, 1:maxval(Re_size))) do i = 1, 2 @@ -151,15 +103,11 @@ contains end if #ifndef __NVCOMPILER_GPU_UNIFIED_MEM - @:ALLOCATE(jac(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(jac(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ALLOCATE(jac_rhs(-1:m,-1:n,-1:p)) if (igr_iter_solver == 1) then ! Jacobi iteration - @:ALLOCATE(jac_old(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end if #else ! create map @@ -167,18 +115,12 @@ contains nv_uvm_temp_on_gpu(1:nv_uvm_igr_temps_on_gpu) = 1 if (nv_uvm_temp_on_gpu(1) == 1) then - @:ALLOCATE(jac(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(jac(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(jac) else - allocate (jac_host(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + allocate (jac_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) - jac(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end) => jac_host(:, :, :) + jac(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end) => jac_host(:,:,:) end if if (nv_uvm_temp_on_gpu(2) == 1) then @@ -186,28 +128,23 @@ contains @:PREFER_GPU(jac_rhs) else allocate (jac_rhs_host(-1:m, -1:n, -1:p)) - jac_rhs(-1:m, -1:n, -1:p) => jac_rhs_host(:, :, :) + jac_rhs(-1:m, -1:n, -1:p) => jac_rhs_host(:,:,:) end if if (igr_iter_solver == 1) then ! Jacobi iteration if (nv_uvm_temp_on_gpu(3) == 1) then - @:ALLOCATE(jac_old(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(jac_old) else - allocate (jac_old_host(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + allocate (jac_old_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) - jac_old(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end) => jac_old_host(:, :, :) + jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end) => jac_old_host(:,:,:) end if end if #endif - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end @@ -227,7 +164,7 @@ contains #:if not MFC_CASE_OPTIMIZATION if (igr_order == 3) then - vidxb = -1; vidxe = 2; + vidxb = -1; vidxe = 2; $:GPU_UPDATE(device='[vidxb, vidxe]') @:ALLOCATE(coeff_L(0:2)) @@ -239,9 +176,8 @@ contains coeff_R(1) = (2._wp/6._wp) coeff_R(0) = (5._wp/6._wp) coeff_R(-1) = (-1._wp/6._wp) - - elseif (igr_order == 5) then - vidxb = -2; vidxe = 3; + else if (igr_order == 5) then + vidxb = -2; vidxe = 3; $:GPU_UPDATE(device='[vidxb, vidxe]') @:ALLOCATE(coeff_L(-1:3)) @@ -270,21 +206,18 @@ contains jac_sf(1)%sf => jac $:GPU_ENTER_DATA(copyin='[jac_sf(1)%sf]') $:GPU_ENTER_DATA(attach='[jac_sf(1)%sf]') - end subroutine s_initialize_igr_module - !> @brief Iteratively solves the implicit gradient reconstruction system using Jacobi or Gauss-Seidel relaxation. subroutine s_igr_iterative_solve(q_cons_vf, bc_type, t_step) #ifdef _CRAYFTN - !DIR$ OPTIMIZE (-haggress) + ! DIR$ OPTIMIZE (-haggress) #endif - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - integer, intent(in) :: t_step - - real(wp) :: rho_rx, rho_ry, rho_rz, rho_lx, rho_ly, rho_lz - real(wp) :: fd_coeff - integer :: num_iters + integer, intent(in) :: t_step + real(wp) :: rho_rx, rho_ry, rho_rz, rho_lx, rho_ly, rho_lz + real(wp) :: fd_coeff + integer :: num_iters if (t_step == t_step_start) then num_iters = num_igr_warm_start_iters @@ -293,7 +226,7 @@ contains end if do q = 1, num_iters - $:GPU_PARALLEL_LOOP(collapse=3, private='[j,k,l,rho_lx, rho_rx, rho_ly, rho_ry, rho_lz, rho_rz, fd_coeff]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_lx, rho_rx, rho_ly, rho_ry, rho_lz, rho_rz, fd_coeff]') do l = 0, p do k = 0, n do j = 0, m @@ -318,9 +251,8 @@ contains fd_coeff = fd_coeff + q_cons_vf(i)%sf(j, k, l) end do - fd_coeff = 1._wp/fd_coeff + alf_igr* & - ((1._wp/dx(j)**2._wp)*(1._wp/rho_lx + 1._wp/rho_rx) + & - (1._wp/dy(k)**2._wp)*(1._wp/rho_ly + 1._wp/rho_ry)) + fd_coeff = 1._wp/fd_coeff + alf_igr*((1._wp/dx(j)**2._wp)*(1._wp/rho_lx + 1._wp/rho_rx) + (1._wp/dy(k) & + & **2._wp)*(1._wp/rho_ly + 1._wp/rho_ry)) if (num_dims == 3) then fd_coeff = fd_coeff + alf_igr*(1._wp/dz(l)**2._wp)*(1._wp/rho_lz + 1._wp/rho_rz) @@ -328,29 +260,29 @@ contains if (igr_iter_solver == 1) then ! Jacobi iteration if (num_dims == 3) then - jac(j, k, l) = real((alf_igr/fd_coeff)* & - ((1._wp/dx(j)**2._wp)*(jac_old(j - 1, k, l)/rho_lx + jac_old(j + 1, k, l)/rho_rx) + & - (1._wp/dy(k)**2._wp)*(jac_old(j, k - 1, l)/rho_ly + jac_old(j, k + 1, l)/rho_ry) + & - (1._wp/dz(l)**2._wp)*(jac_old(j, k, l - 1)/rho_lz + jac_old(j, k, l + 1)/rho_rz)) + & - real(jac_rhs(j, k, l), kind=wp)/fd_coeff, kind=stp) + jac(j, k, l) = real((alf_igr/fd_coeff)*((1._wp/dx(j)**2._wp)*(jac_old(j - 1, k, & + & l)/rho_lx + jac_old(j + 1, k, l)/rho_rx) + (1._wp/dy(k)**2._wp)*(jac_old(j, k - 1, & + & l)/rho_ly + jac_old(j, k + 1, l)/rho_ry) + (1._wp/dz(l)**2._wp)*(jac_old(j, k, & + & l - 1)/rho_lz + jac_old(j, k, l + 1)/rho_rz)) + real(jac_rhs(j, k, l), kind=wp)/fd_coeff, & + & kind=stp) else - jac(j, k, l) = real((alf_igr/fd_coeff)* & - ((1._wp/dx(j)**2._wp)*(real(jac_old(j - 1, k, l), kind=wp)/rho_lx + real(jac_old(j + 1, k, l), kind=wp)/rho_rx) + & - (1._wp/dy(k)**2._wp)*(real(jac_old(j, k - 1, l), kind=wp)/rho_ly + real(jac_old(j, k + 1, l), kind=wp)/rho_ry)) + & - real(jac_rhs(j, k, l), kind=wp)/fd_coeff, kind=stp) + jac(j, k, l) = real((alf_igr/fd_coeff)*((1._wp/dx(j)**2._wp)*(real(jac_old(j - 1, k, l), & + & kind=wp)/rho_lx + real(jac_old(j + 1, k, l), & + & kind=wp)/rho_rx) + (1._wp/dy(k)**2._wp)*(real(jac_old(j, k - 1, l), & + & kind=wp)/rho_ly + real(jac_old(j, k + 1, l), kind=wp)/rho_ry)) + real(jac_rhs(j, k, l), & + & kind=wp)/fd_coeff, kind=stp) end if else ! Gauss Seidel iteration if (num_dims == 3) then - jac(j, k, l) = real((alf_igr/fd_coeff)* & - ((1._wp/dx(j)**2._wp)*(jac(j - 1, k, l)/rho_lx + jac(j + 1, k, l)/rho_rx) + & - (1._wp/dy(k)**2._wp)*(jac(j, k - 1, l)/rho_ly + jac(j, k + 1, l)/rho_ry) + & - (1._wp/dz(l)**2._wp)*(jac(j, k, l - 1)/rho_lz + jac(j, k, l + 1)/rho_rz)) + & - real(jac_rhs(j, k, l), kind=wp)/fd_coeff, kind=stp) + jac(j, k, l) = real((alf_igr/fd_coeff)*((1._wp/dx(j)**2._wp)*(jac(j - 1, k, & + & l)/rho_lx + jac(j + 1, k, l)/rho_rx) + (1._wp/dy(k)**2._wp)*(jac(j, k - 1, & + & l)/rho_ly + jac(j, k + 1, l)/rho_ry) + (1._wp/dz(l)**2._wp)*(jac(j, k, & + & l - 1)/rho_lz + jac(j, k, l + 1)/rho_rz)) + real(jac_rhs(j, k, l), kind=wp)/fd_coeff, & + & kind=stp) else - jac(j, k, l) = real((alf_igr/fd_coeff)* & - ((1._wp/dx(j)**2._wp)*(jac(j - 1, k, l)/rho_lx + jac(j + 1, k, l)/rho_rx) + & - (1._wp/dy(k)**2._wp)*(jac(j, k - 1, l)/rho_ly + jac(j, k + 1, l)/rho_ry)) + & - real(jac_rhs(j, k, l), kind=wp)/fd_coeff, kind=stp) + jac(j, k, l) = real((alf_igr/fd_coeff)*((1._wp/dx(j)**2._wp)*(jac(j - 1, k, & + & l)/rho_lx + jac(j + 1, k, l)/rho_rx) + (1._wp/dy(k)**2._wp)*(jac(j, k - 1, & + & l)/rho_ly + jac(j, k + 1, l)/rho_ry)) + real(jac_rhs(j, k, l), kind=wp)/fd_coeff, kind=stp) end if end if end do @@ -361,7 +293,7 @@ contains call s_populate_F_igr_buffers(bc_type, jac_sf) if (igr_iter_solver == 1 .or. dummy) then ! Jacobi iteration - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end @@ -372,33 +304,25 @@ contains $:END_GPU_PARALLEL_LOOP() end if end do - end subroutine s_igr_iterative_solve - !> @brief Computes the IGR viscous stress contribution in the x-direction and accumulates it into the RHS. subroutine s_igr_sigma_x(q_cons_vf, rhs_vf) #ifdef _CRAYFTN - !DIR$ OPTIMIZE (-haggress) + ! DIR$ OPTIMIZE (-haggress) #endif - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: rhs_vf - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf - - real(wp) :: F_L, vel_L, rho_L, F_R, vel_R, rho_R + type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + real(wp) :: F_L, vel_L, rho_L, F_R, vel_R, rho_R #:if not MFC_CASE_OPTIMIZATION real(wp), dimension(num_fluids_max) :: alpha_rho_L, alpha_rho_R #:else real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R #:endif - $:GPU_PARALLEL_LOOP(collapse=3, private='[j,k,l,F_L, vel_L, alpha_rho_L, F_R, vel_R, alpha_rho_R, rho_L, rho_R]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, F_L, vel_L, alpha_rho_L, F_R, vel_R, alpha_rho_R, rho_L, rho_R]') do l = 0, p do k = 0, n do j = -1, m - F_L = 0._wp; F_R = 0._wp vel_L = 0._wp; vel_R = 0._wp rho_L = 0._wp; rho_R = 0._wp @@ -442,76 +366,69 @@ contains #:for LR in ['L', 'R'] $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) + & - real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) + real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) + & - real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) + real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j)), & + & kind=stp) #:endfor end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_igr_sigma_x - !> @brief Evaluates the approximate Riemann solver for the IGR scheme along a given coordinate direction. subroutine s_igr_riemann_solver(q_cons_vf, rhs_vf, idir) #ifdef _CRAYFTN - !DIR$ OPTIMIZE (-haggress) + ! DIR$ OPTIMIZE (-haggress) #endif - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: rhs_vf - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf - integer, intent(in) :: idir - - real(wp) :: cfl - real(wp) :: rho_L, gamma_L, pi_inf_L, E_L, mu_L, F_L, pres_L - real(wp) :: rho_R, gamma_R, pi_inf_R, E_R, mu_R, F_R, pres_R - real(wp), dimension(3) :: vflux_L_arr, vflux_R_arr - real(wp), dimension(-1:1) :: rho_sf_small + type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + integer, intent(in) :: idir + real(wp) :: cfl + real(wp) :: rho_L, gamma_L, pi_inf_L, E_L, mu_L, F_L, pres_L + real(wp) :: rho_R, gamma_R, pi_inf_R, E_R, mu_R, F_R, pres_R + real(wp), dimension(3) :: vflux_L_arr, vflux_R_arr + real(wp), dimension(-1:1) :: rho_sf_small #:if not MFC_CASE_OPTIMIZATION real(wp), dimension(num_fluids_max) :: alpha_rho_L, alpha_L, alpha_R, alpha_rho_R - real(wp), dimension(3) :: vel_L, vel_R - real(wp), dimension(3, 3) :: dvel - real(wp), dimension(3) :: dvel_small + real(wp), dimension(3) :: vel_L, vel_R + real(wp), dimension(3, 3) :: dvel + real(wp), dimension(3) :: dvel_small #:else - real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_L, alpha_R, alpha_rho_R - real(wp), dimension(num_dims) :: vel_L, vel_R + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_L, alpha_R, alpha_rho_R + real(wp), dimension(num_dims) :: vel_L, vel_R real(wp), dimension(num_dims, num_dims) :: dvel - real(wp), dimension(num_dims) :: dvel_small + real(wp), dimension(num_dims) :: dvel_small #:endif if (idir == 1) then if (p == 0) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - $:GPU_PARALLEL_LOOP(collapse=3, private='[j,k,l,rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, & + & dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = 0, n do j = -1, m - vflux_L_arr = 0._wp vflux_R_arr = 0._wp #:if MFC_CASE_OPTIMIZATION #:if igr_order == 5 - !DIR$ unroll 6 + ! DIR$ unroll 6 #:elif igr_order == 3 - !DIR$ unroll 4 + ! DIR$ unroll 4 #:endif #:endif $:GPU_LOOP(parallelism='[seq]') do q = vidxb, vidxe - !x-direction contributions + ! x-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -522,12 +439,10 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dx(j)))*( & - 1._wp*q_cons_vf(momxb)%sf(j + 1 + q, k, l)/rho_sf_small(1) - & - 1._wp*q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb + 1)%sf(j + 1 + q, k, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dx(j)))*(1._wp*q_cons_vf(momxb)%sf(j + 1 + q, k, & + & l)/rho_sf_small(1) - 1._wp*q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1 + q, k, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -545,7 +460,7 @@ contains vflux_R_arr(3) = vflux_R_arr(3) + coeff_R(q)*(4._wp*dvel_small(1))/3._wp end if - !y-direction contributions + ! y-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -556,12 +471,10 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb)%sf(j + q, k + 1, l)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb + 1)%sf(j + q, k + 1, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j + q, k + 1, & + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j + q, k + 1, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -580,9 +493,8 @@ contains end if if (q == 0) then - jac_rhs(j, k, l) = real(alf_igr*(2._wp*(dvel(1, 2)*dvel(2, 1)) & - + dvel(1, 1)**2._wp + dvel(2, 2)**2._wp & - + (dvel(1, 1) + dvel(2, 2))**2._wp), kind=stp) + jac_rhs(j, k, l) = real(alf_igr*(2._wp*(dvel(1, 2)*dvel(2, 1)) + dvel(1, & + & 1)**2._wp + dvel(2, 2)**2._wp + (dvel(1, 1) + dvel(2, 2))**2._wp), kind=stp) end if end do @@ -644,7 +556,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -685,60 +596,60 @@ contains end do $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -753,157 +664,143 @@ contains E_R = E_R + coeff_R(q)*q_cons_vf(E_idx)%sf(j + q, k, l) end do - call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, & - E_R, gamma_R, pi_inf_R, rho_R, vel_R, & - pres_L, pres_R, cfl) + call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & + & vel_R, pres_L, pres_R, cfl) do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(1))*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real((0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(1))*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(alpha_L(i)* & - vel_L(1))*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, l) & - - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, l)*vel_L(1)*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_L(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real((0.5_wp*dt*(alpha_L(i)* & - vel_L(1))*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l)*vel_L(1)*(1._wp/dx(j))), kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + & - pres_L)*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, l) + & - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(vel_L(1)*(E_L + & - pres_L))*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + & - pres_L)*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real((0.5_wp*dt*(vel_L(1)*(E_L + & - pres_L))*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dx(j))), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j))), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(1))*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real((0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(1))*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(alpha_R(i)* & - vel_R(1))*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, l) & - - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real((0.5_wp*dt*(alpha_R(i)* & - vel_R(1))*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(1)*(1._wp/dx(j))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l)*vel_R(1)*(1._wp/dx(j))), kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + & - pres_R)*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, l) + & - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(vel_R(1)*(E_R + & - pres_R))*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + & - pres_R)*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real((0.5_wp*dt*(vel_R(1)*(E_R + & - pres_R))*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dx(j))), kind=stp) - + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j))), kind=stp) end do end do end do @@ -911,25 +808,25 @@ contains #:endif else #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - $:GPU_PARALLEL_LOOP(collapse=3, private='[j,k,l,rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, & + & dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = 0, n do j = -1, m - vflux_L_arr = 0._wp vflux_R_arr = 0._wp #:if MFC_CASE_OPTIMIZATION #:if igr_order == 5 - !DIR$ unroll 6 + ! DIR$ unroll 6 #:elif igr_order == 3 - !DIR$ unroll 4 + ! DIR$ unroll 4 #:endif #:endif $:GPU_LOOP(parallelism='[seq]') do q = vidxb, vidxe - - !x-direction contributions + ! x-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -940,15 +837,12 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb)%sf(j + 1 + q, k, l)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb + 1)%sf(j + 1 + q, k, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) - dvel_small(3) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb + 2)%sf(j + 1 + q, k, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 2)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1 + q, k, & + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1 + q, k, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + dvel_small(3) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 2)%sf(j + 1 + q, k, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -968,7 +862,7 @@ contains vflux_R_arr(3) = vflux_R_arr(3) + coeff_R(q)*(4._wp*dvel_small(1))/3._wp end if - !y-direction contributions + ! y-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -979,15 +873,12 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb)%sf(j + q, k + 1, l)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb + 1)%sf(j + q, k + 1, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) - if (q == 0) dvel_small(3) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb + 2)%sf(j + q, k + 1, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 2)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j + q, k + 1, & + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j + q, k + 1, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + if (q == 0) dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j + q, k + 1, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j + q, k - 1, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -1004,7 +895,7 @@ contains vflux_R_arr(3) = vflux_R_arr(3) + coeff_R(q)*(-2._wp*dvel_small(2))/3._wp end if - !z-direction contributions + ! z-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -1015,15 +906,12 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dz(l)))*( & - q_cons_vf(momxb)%sf(j + q, k, l + 1)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j + q, k, l - 1)/rho_sf_small(-1)) - if (q == 0) dvel_small(2) = (1/(2._wp*dz(l)))*( & - q_cons_vf(momxb + 1)%sf(j + q, k, l + 1)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j + q, k, l - 1)/rho_sf_small(-1)) - dvel_small(3) = (1/(2._wp*dz(l)))*( & - q_cons_vf(momxb + 2)%sf(j + q, k, l + 1)/rho_sf_small(1) - & - q_cons_vf(momxb + 2)%sf(j + q, k, l - 1)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb)%sf(j + q, k, & + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k, l - 1)/rho_sf_small(-1)) + if (q == 0) dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j + q, k, & + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k, l - 1)/rho_sf_small(-1)) + dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j + q, k, & + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j + q, k, l - 1)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -1041,12 +929,9 @@ contains end if if (q == 0) then - jac_rhs(j, k, l) = real(alf_igr*(2._wp*(dvel(1, 2)*dvel(2, 1) & - + dvel(1, 3)*dvel(3, 1) & - + dvel(2, 3)*dvel(3, 2)) & - + dvel(1, 1)**2._wp + dvel(2, 2)**2._wp & - + dvel(3, 3)**2._wp & - + (dvel(1, 1) + dvel(2, 2) + dvel(3, 3))**2._wp), kind=stp) + jac_rhs(j, k, l) = real(alf_igr*(2._wp*(dvel(1, 2)*dvel(2, 1) + dvel(1, 3)*dvel(3, & + & 1) + dvel(2, 3)*dvel(3, 2)) + dvel(1, 1)**2._wp + dvel(2, 2)**2._wp + dvel(3, & + & 3)**2._wp + (dvel(1, 1) + dvel(2, 2) + dvel(3, 3))**2._wp), kind=stp) end if end do @@ -1108,7 +993,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -1150,88 +1034,88 @@ contains end do $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -1246,178 +1130,164 @@ contains E_R = E_R + coeff_R(q)*q_cons_vf(E_idx)%sf(j + q, k, l) end do - call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, & - E_R, gamma_R, pi_inf_R, rho_R, vel_R, & - pres_L, pres_R, cfl) + call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(1))*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real((0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(1))*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(alpha_L(i)* & - vel_L(1))*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, l) & - - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, l)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_L(i)* & - vel_L(1))*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + & - pres_L)*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, l) + & - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, l) + & - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(vel_L(1)*(E_L + & - pres_L))*(1._wp/dx(j + 1)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + & - pres_L)*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) - & - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real((0.5_wp*dt*(vel_L(1)*(E_L + & - pres_L))*(1._wp/dx(j)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dx(j))), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j))), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(1))*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real((0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(1))*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(alpha_R(i)* & - vel_R(1))*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, l) & - - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real((0.5_wp*dt*(alpha_R(i)* & - vel_R(1))*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(1)*(1._wp/dx(j))), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l)*vel_R(1)*(1._wp/dx(j))), kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + & - pres_R)*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, l) + & - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, l) + & - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, l) + & - real((0.5_wp*dt*(vel_R(1)*(E_R + & - pres_R))*(1._wp/dx(j + 1)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dx(j + 1))), kind=stp) + rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & + & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + & - pres_R)*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) - & - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j))), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real((0.5_wp*dt*(vel_R(1)*(E_R + & - pres_R))*(1._wp/dx(j)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dx(j))), kind=stp) - + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j))), kind=stp) end do end do end do @@ -1427,26 +1297,26 @@ contains else if (idir == 2) then if (p == 0) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - $:GPU_PARALLEL_LOOP(collapse=3, private='[j,k,l,rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, & + & dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = -1, n do j = 0, m - if (viscous) then vflux_L_arr = 0._wp vflux_R_arr = 0._wp #:if MFC_CASE_OPTIMIZATION #:if igr_order == 5 - !DIR$ unroll 6 + ! DIR$ unroll 6 #:elif igr_order == 3 - !DIR$ unroll 4 + ! DIR$ unroll 4 #:endif #:endif $:GPU_LOOP(parallelism='[seq]') do q = vidxb, vidxe - - !x-direction contributions + ! x-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -1457,12 +1327,10 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb)%sf(j + 1, k + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb + 1)%sf(j + 1, k + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1, k + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(2)) @@ -1473,7 +1341,7 @@ contains vflux_R_arr(3) = vflux_R_arr(3) + coeff_R(q)*(-2._wp*dvel_small(1))/3._wp end if - !y-direction contributions + ! y-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -1484,12 +1352,10 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb)%sf(j, k + 1 + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb + 1)%sf(j, k + 1 + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j, k + 1 + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1 + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) @@ -1560,7 +1426,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -1602,60 +1467,60 @@ contains end do $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -1673,150 +1538,137 @@ contains F_R = F_R + coeff_R(q)*jac(j, k + q, l) end do - call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, & - E_R, gamma_R, pi_inf_R, rho_R, vel_R, & - pres_L, pres_R, cfl) + call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(2))*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(2))*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(alpha_L(i)* & - vel_L(2))*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, l) & - - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_L(i)* & - vel_L(2))*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + & - pres_L + F_L)*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, l) + & - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(vel_L(2)*(E_L + & - pres_L + F_L))*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + & - pres_L + F_L)*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real(0.5_wp*dt*(vel_L(2)*(E_L + & - pres_L + F_L))*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dy(k)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(2))*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(2))*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(alpha_R(i)* & - vel_R(2))*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, l) & - - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_R(i)* & - vel_R(2))*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + & - pres_R + F_R)*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) - $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, l) + & - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) - $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(vel_R(2)*(E_R + & - pres_R + F_R))*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k + 1)), kind=stp) - $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + & - pres_R + F_R)*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) - $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k)), kind=stp) - $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real(0.5_wp*dt*(vel_R(2)*(E_R + & - pres_R + F_R))*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) + $:GPU_ATOMIC(atomic='update') + rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) + $:GPU_ATOMIC(atomic='update') + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k + 1)), kind=stp) + $:GPU_ATOMIC(atomic='update') + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) + $:GPU_ATOMIC(atomic='update') + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1) & + & )*(1._wp/dy(k)), kind=stp) + $:GPU_ATOMIC(atomic='update') + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dy(k)), kind=stp) end do end do end do @@ -1824,26 +1676,26 @@ contains #:endif else #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - $:GPU_PARALLEL_LOOP(collapse=3, private='[j,k,l,rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, & + & dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = -1, n do j = 0, m - if (viscous) then vflux_L_arr = 0._wp vflux_R_arr = 0._wp #:if MFC_CASE_OPTIMIZATION #:if igr_order == 5 - !DIR$ unroll 6 + ! DIR$ unroll 6 #:elif igr_order == 3 - !DIR$ unroll 4 + ! DIR$ unroll 4 #:endif #:endif $:GPU_LOOP(parallelism='[seq]') do q = vidxb, vidxe - - !x-direction contributions + ! x-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -1854,12 +1706,10 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb)%sf(j + 1, k + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb + 1)%sf(j + 1, k + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1, k + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(2)) @@ -1870,7 +1720,7 @@ contains vflux_R_arr(3) = vflux_R_arr(3) + coeff_R(q)*(-2._wp*dvel_small(1))/3._wp end if - !y-direction contributions + ! y-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -1881,15 +1731,12 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb)%sf(j, k + 1 + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb + 1)%sf(j, k + 1 + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) - dvel_small(3) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb + 2)%sf(j, k + 1 + q, l)/rho_sf_small(1) - & - q_cons_vf(momxb + 2)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j, k + 1 + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1 + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j, k + 1 + q, & + & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) @@ -1902,7 +1749,7 @@ contains vflux_R_arr(3) = vflux_R_arr(3) + coeff_R(q)*(4._wp*dvel_small(2))/3._wp end if - !z-direction contributions + ! z-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -1913,12 +1760,12 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(2) = (1/(2._wp*dz(l)))*( & - q_cons_vf(momxb + 1)%sf(j, k + q, l + 1)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j, k + q, l - 1)/rho_sf_small(-1)) - dvel_small(3) = (1/(2._wp*dz(l)))*( & - q_cons_vf(momxb + 2)%sf(j, k + q, l + 1)/rho_sf_small(1) - & - q_cons_vf(momxb + 2)%sf(j, k + q, l - 1)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j, k + q, & + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k + q, & + & l - 1)/rho_sf_small(-1)) + dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j, k + q, & + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k + q, & + & l - 1)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(2)) vflux_L_arr(3) = vflux_L_arr(3) + coeff_L(q)*(-2._wp*dvel_small(3))/3._wp @@ -1988,7 +1835,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -2030,88 +1876,88 @@ contains end do $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -2129,206 +1975,192 @@ contains F_R = F_R + coeff_R(q)*jac(j, k + q, l) end do - call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, & - E_R, gamma_R, pi_inf_R, rho_R, vel_R, & - pres_L, pres_R, cfl) + call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(2))*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(2))*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(alpha_L(i)* & - vel_L(2))*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, l) & - - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_L(i)* & - vel_L(2))*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + & - pres_L + F_L)*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, l) + & - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, l) + & - real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(vel_L(2)*(E_L + & - pres_L + F_L))*(1._wp/dy(k + 1)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + & - pres_L + F_L)*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) - & - real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(3) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real(0.5_wp*dt*(vel_L(2)*(E_L + & - pres_L + F_L))*(1._wp/dy(k)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dy(k)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(2))*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(2))*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(alpha_R(i)* & - vel_R(2))*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, l) & - - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_R(i)* & - vel_R(2))*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + & - pres_R + F_R)*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, l) + & - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, l) + & - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, l) + & - real(0.5_wp*dt*(vel_R(2)*(E_R + & - pres_R + F_R))*(1._wp/dy(k + 1)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & + & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + & - pres_R + F_R)*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) - & - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dy(k)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(3) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real(0.5_wp*dt*(vel_R(2)*(E_R + & - pres_R + F_R))*(1._wp/dy(k)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k)), kind=stp) - + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dy(k)), kind=stp) end do end do end do $:END_GPU_PARALLEL_LOOP() #:endif end if - elseif (idir == 3) then + else if (idir == 3) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - $:GPU_PARALLEL_LOOP(collapse=3, private='[j,k,l,rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, mu_R, & + & vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, dvel_small, & + & rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = -1, p do k = 0, n do j = 0, m - if (viscous) then vflux_L_arr = 0._wp vflux_R_arr = 0._wp #:if MFC_CASE_OPTIMIZATION #:if igr_order == 5 - !DIR$ unroll 6 + ! DIR$ unroll 6 #:elif igr_order == 3 - !DIR$ unroll 4 + ! DIR$ unroll 4 #:endif #:endif $:GPU_LOOP(parallelism='[seq]') do q = vidxb, vidxe - - !x-direction contributions + ! x-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -2339,12 +2171,10 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb)%sf(j + 1, k, l + q)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j - 1, k, l + q)/rho_sf_small(-1)) - dvel_small(3) = (1/(2._wp*dx(j)))*( & - q_cons_vf(momxb + 2)%sf(j + 1, k, l + q)/rho_sf_small(1) - & - q_cons_vf(momxb + 2)%sf(j - 1, k, l + q)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k, & + & l + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k, l + q)/rho_sf_small(-1)) + dvel_small(3) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 2)%sf(j + 1, k, & + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1, k, l + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(3)) @@ -2355,7 +2185,7 @@ contains vflux_R_arr(3) = vflux_R_arr(3) + coeff_R(q)*(-2._wp*dvel_small(1))/3._wp end if - !y-direction contributions + ! y-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -2366,12 +2196,10 @@ contains rho_sf_small(i) = rho_L end do - dvel_small(2) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb + 1)%sf(j, k + 1, l + q)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j, k - 1, l + q)/rho_sf_small(-1)) - dvel_small(3) = (1/(2._wp*dy(k)))*( & - q_cons_vf(momxb + 2)%sf(j, k + 1, l + q)/rho_sf_small(1) - & - q_cons_vf(momxb + 2)%sf(j, k - 1, l + q)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1, & + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1, l + q)/rho_sf_small(-1)) + dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j, k + 1, & + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1, l + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(3)) @@ -2382,7 +2210,7 @@ contains vflux_R_arr(3) = vflux_R_arr(3) + coeff_R(q)*(-2._wp*dvel_small(2))/3._wp end if - !z-direction contributions + ! z-direction contributions $:GPU_LOOP(parallelism='[seq]') do i = -1, 1 rho_L = 0._wp @@ -2392,15 +2220,14 @@ contains end do rho_sf_small(i) = rho_L end do - dvel_small(1) = (1/(2._wp*dz(l)))*( & - q_cons_vf(momxb)%sf(j, k, l + 1 + q)/rho_sf_small(1) - & - q_cons_vf(momxb)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) - dvel_small(2) = (1/(2._wp*dz(l)))*( & - q_cons_vf(momxb + 1)%sf(j, k, l + 1 + q)/rho_sf_small(1) - & - q_cons_vf(momxb + 1)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) - dvel_small(3) = (1/(2._wp*dz(l)))*( & - q_cons_vf(momxb + 2)%sf(j, k, l + 1 + q)/rho_sf_small(1) - & - q_cons_vf(momxb + 2)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) + dvel_small(1) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb)%sf(j, k, & + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) + dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j, k, & + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k, & + & l - 1 + q)/rho_sf_small(-1)) + dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j, k, & + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k, & + & l - 1 + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(2)) @@ -2473,7 +2300,6 @@ contains end do if (num_fluids > 1) then - alpha_L(num_fluids) = 1._wp alpha_R(num_fluids) = 1._wp @@ -2515,88 +2341,88 @@ contains end do $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, l + 1) - & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) + & - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -2614,199 +2440,180 @@ contains F_R = F_R + coeff_R(q)*jac(j, k, l + q) end do - call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, & - E_R, gamma_R, pi_inf_R, rho_R, vel_R, & - pres_L, pres_R, cfl) + call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, vel_R, & + & pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l + 1) = rhs_vf(i)%sf(j, k, l + 1) + & - real(0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(3))*(1._wp/dz(l + 1)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(i)%sf(j, k, l + 1) = rhs_vf(i)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_rho_L(i)* & - vel_L(3))*(1._wp/dz(l)) - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l)), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l)), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, l + 1) + & - real(0.5_wp*dt*(alpha_L(i)* & - vel_L(3))*(1._wp/dz(l + 1)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, l + 1) & - - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l + 1)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l + 1)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_L(i)* & - vel_L(3))*(1._wp/dz(l)) - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dz(l)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(alpha_L(i)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(3)*(1._wp/dz(l)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(3)*(1._wp/dz(l)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, l + 1) + & - real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + & - pres_L + F_L)*(1._wp/dz(l + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, l + 1) + & - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, l + 1) + & - real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l + 1)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, l + 1) + & - real(0.5_wp*dt*(vel_L(3)*(E_L + & - pres_L + F_L))*(1._wp/dz(l + 1)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) - & - real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + & - pres_L + F_L)*(1._wp/dz(l)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) - real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l)) - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real(0.5_wp*dt*(vel_L(3)*(E_L + & - pres_L + F_L))*(1._wp/dz(l)) - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dz(l)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dz(l)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l + 1) = rhs_vf(i)%sf(j, k, l + 1) + & - real(0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(3))*(1._wp/dz(l + 1)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(i)%sf(j, k, l + 1) = rhs_vf(i)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_rho_R(i)* & - vel_R(3))*(1._wp/dz(l)) + & - 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l)), kind=stp) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l)), kind=stp) end do if (num_fluids > 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, l + 1) + & - real(0.5_wp*dt*(alpha_R(i)* & - vel_R(3))*(1._wp/dz(l + 1)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, l + 1) & - - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l + 1)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l + 1)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) - & - real(0.5_wp*dt*(alpha_R(i)* & - vel_R(3))*(1._wp/dz(l)) + & - 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dz(l)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(alpha_R(i)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, l) & - + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(3)*(1._wp/dz(l)), kind=stp) + rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(3)*(1._wp/dz(l)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, l + 1) + & - real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + & - pres_R + F_R)*(1._wp/dz(l + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, l + 1) + & - real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, l + 1) + & - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l + 1)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, l + 1) + & - real(0.5_wp*dt*(vel_R(3)*(E_R + & - pres_R + F_R))*(1._wp/dz(l + 1)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dz(l + 1)), kind=stp) + rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & + & l + 1) + real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, l) - & - real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + & - pres_R + F_R)*(1._wp/dz(l)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & + & l) - real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - & - real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) - & - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l)) + & - 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dz(l)), kind=stp) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') - rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - & - real(0.5_wp*dt*(vel_R(3)*(E_R + & - pres_R + F_R))*(1._wp/dz(l)) + & - 0.5_wp*dt*cfl*(E_R)*(1._wp/dz(l)), kind=stp) - + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) - real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dz(l)), kind=stp) end do end do end do $:END_GPU_PARALLEL_LOOP() #:endif end if - end subroutine s_igr_riemann_solver - !> @brief Computes pressure and maximum wavespeed from left and right reconstructed states for the IGR Riemann solver. - subroutine s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, & - E_R, gamma_R, pi_inf_R, rho_R, vel_R, & - pres_L, pres_R, cfl) + subroutine s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, vel_R, pres_L, pres_R, cfl) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in) :: E_L, gamma_L, pi_inf_L, rho_L - real(wp), intent(in) :: E_R, gamma_R, pi_inf_R, rho_R + real(wp), intent(in) :: E_L, gamma_L, pi_inf_L, rho_L + real(wp), intent(in) :: E_R, gamma_R, pi_inf_R, rho_R real(wp), dimension(num_dims), intent(in) :: vel_L, vel_R - real(wp), intent(out) :: pres_L, pres_R, cfl - - real(wp) :: a_L, a_R + real(wp), intent(out) :: pres_L, pres_R, cfl + real(wp) :: a_L, a_R if (num_dims == 2) then pres_L = (E_L - pi_inf_L - 0.5_wp*rho_L*(vel_L(1)**2._wp + vel_L(2)**2._wp))/gamma_L @@ -2820,10 +2627,8 @@ contains a_L = sqrt((pres_L*(1._wp/gamma_L + 1._wp) + pi_inf_L/gamma_L)/rho_L) a_R = sqrt((pres_R*(1._wp/gamma_R + 1._wp) + pi_inf_R/gamma_R)/rho_R) - cfl = max(sqrt(vel_L(1)**2._wp + vel_L(2)**2._wp), & - sqrt(vel_R(1)**2._wp + vel_R(2)**2._wp)) + & - max(a_L, a_R) - elseif (num_dims == 3) then + cfl = max(sqrt(vel_L(1)**2._wp + vel_L(2)**2._wp), sqrt(vel_R(1)**2._wp + vel_R(2)**2._wp)) + max(a_L, a_R) + else if (num_dims == 3) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 pres_L = (E_L - pi_inf_L - 0.5_wp*rho_L*(vel_L(1)**2._wp + vel_L(2)**2._wp + vel_L(3)**2._wp))/gamma_L pres_R = (E_R - pi_inf_R - 0.5_wp*rho_R*(vel_R(1)**2._wp + vel_R(2)**2._wp + vel_R(3)**2._wp))/gamma_R @@ -2837,73 +2642,57 @@ contains a_R = sqrt((pres_R*(1._wp/gamma_R + 1._wp) + pi_inf_R/gamma_R)/rho_R) cfl = max(sqrt(vel_L(1)**2._wp + vel_L(2)**2._wp + vel_L(3)**2._wp), & - sqrt(vel_R(1)**2._wp + vel_R(2)**2._wp + vel_R(3)**2._wp)) + & - max(a_L, a_R) + & sqrt(vel_R(1)**2._wp + vel_R(2)**2._wp + vel_R(3)**2._wp)) + max(a_L, a_R) #:endif end if - end subroutine s_get_derived_states - !> @brief Accumulates the IGR numerical flux divergence into the right-hand side along the specified coordinate direction. subroutine s_igr_flux_add(q_cons_vf, rhs_vf, flux_vf, idir) - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf, flux_vf, rhs_vf - - integer, intent(in) :: idir + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, flux_vf, rhs_vf + integer, intent(in) :: idir if (idir == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = 1, sys_size do l = 0, p do k = 0, n do j = 0, m - rhs_vf(i)%sf(j, k, l) = 1._wp/dx(j)* & - (flux_vf(i)%sf(j - 1, k, l) & - - flux_vf(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = 1._wp/dx(j)*(flux_vf(i)%sf(j - 1, k, l) - flux_vf(i)%sf(j, k, l)) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - elseif (idir == 2) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + else if (idir == 2) then + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = 1, sys_size do l = 0, p do k = 0, n do j = 0, m - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)* & - (flux_vf(i)%sf(j, k - 1, l) & - - flux_vf(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_vf(i)%sf(j, k - 1, & + & l) - flux_vf(i)%sf(j, k, l)) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - elseif (idir == 3) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + else if (idir == 3) then + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = 1, sys_size do l = 0, p do k = 0, n do j = 0, m - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)* & - (flux_vf(i)%sf(j, k, l - 1) & - - flux_vf(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_vf(i)%sf(j, k, & + & l - 1) - flux_vf(i)%sf(j, k, l)) end do end do end do end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_igr_flux_add - !> @brief Deallocates all arrays and GPU resources allocated by the IGR module. subroutine s_finalize_igr_module() - if (viscous) then @:DEALLOCATE(Res_igr) end if @@ -2942,7 +2731,5 @@ contains #:if not MFC_CASE_OPTIMIZATION @:DEALLOCATE(coeff_L, coeff_R) #:endif - end subroutine s_finalize_igr_module - end module m_igr diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index efe3d53cd2..29ca383e4f 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -7,7 +7,6 @@ !> @brief MPI halo exchange, domain decomposition, and buffer packing/unpacking for the simulation solver module m_mpi_proxy - #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -40,24 +39,18 @@ module m_mpi_proxy integer :: i_halo_size $:GPU_DECLARE(create='[i_halo_size]') - contains !> @brief Allocates immersed boundary communication buffers for MPI halo exchanges. subroutine s_initialize_mpi_proxy_module() - #ifdef MFC_MPI if (ib) then if (n > 0) then if (p > 0) then - i_halo_size = -1 + buff_size* & - & (m + 2*buff_size + 1)* & - & (n + 2*buff_size + 1)* & - & (p + 2*buff_size + 1)/ & - & (cells_bounds%mnp_min + 2*buff_size + 1) + i_halo_size = -1 + buff_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)*(p + 2*buff_size + 1) & + & /(cells_bounds%mnp_min + 2*buff_size + 1) else - i_halo_size = -1 + buff_size* & - & (cells_bounds%mn_max + 2*buff_size + 1) + i_halo_size = -1 + buff_size*(cells_bounds%mn_max + 2*buff_size + 1) end if else i_halo_size = -1 + buff_size @@ -67,16 +60,11 @@ contains @:ALLOCATE(ib_buff_send(0:i_halo_size), ib_buff_recv(0:i_halo_size)) end if #endif - end subroutine s_initialize_mpi_proxy_module - - !> Since only the processor with rank 0 reads and verifies - !! the consistency of user inputs, these are initially not - !! available to the other processors. Then, the purpose of - !! this subroutine is to distribute the user inputs to the - !! remaining processors in the communicator. + !> Since only the processor with rank 0 reads and verifies the consistency of user inputs, these are initially not available to + !! the other processors. Then, the purpose of this subroutine is to distribute the user inputs to the remaining processors in + !! the communicator. impure subroutine s_mpi_bcast_user_inputs() - #ifdef MFC_MPI integer :: i, j !< Generic loop iterator @@ -253,32 +241,24 @@ contains call MPI_BCAST(nv_uvm_out_of_core, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(nv_uvm_igr_temps_on_gpu, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(nv_uvm_pref_gpu, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) - #endif - end subroutine s_mpi_bcast_user_inputs - !> @brief Broadcasts random phase numbers from rank 0 to all MPI processes. impure subroutine s_mpi_send_random_number(phi_rn, num_freq) - integer, intent(in) :: num_freq + integer, intent(in) :: num_freq real(wp), intent(inout), dimension(1:num_freq) :: phi_rn #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_BCAST(phi_rn, num_freq, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif - end subroutine s_mpi_send_random_number - !> @brief Deallocates immersed boundary MPI communication buffers. subroutine s_finalize_mpi_proxy_module() - #ifdef MFC_MPI if (ib) then @:DEALLOCATE(ib_buff_send, ib_buff_recv) end if #endif - end subroutine s_finalize_mpi_proxy_module - end module m_mpi_proxy diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index de1af10f24..82f14d2d19 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -6,7 +6,6 @@ !> @brief MUSCL reconstruction with interface sharpening for contact-preserving advection module m_muscl - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -21,39 +20,32 @@ module m_muscl use m_helper - private; public :: s_initialize_muscl_module, & - s_muscl, & - s_finalize_muscl_module, & - s_interface_compression + private; public :: s_initialize_muscl_module, s_muscl, s_finalize_muscl_module, s_interface_compression integer :: v_size $:GPU_DECLARE(create='[v_size]') type(int_bounds_info) :: is1_muscl, is2_muscl, is3_muscl - $:GPU_DECLARE(create='[is1_muscl,is2_muscl,is3_muscl]') - - !> @name The cell-average variables that will be MUSCL-reconstructed. Formerly, they - !! are stored in v_vf. However, they are transferred to v_rs_wsL and v_rs_wsR - !! as to be reshaped (RS) and/or characteristically decomposed. The reshaping - !! allows the muscl procedure to be independent of the coordinate direction of - !! the reconstruction. Lastly, notice that the left (L) and right (R) results - !! of the characteristic decomposition are stored in custom-constructed muscl- - !! stencils (WS) that are annexed to each position of a given scalar field. + $:GPU_DECLARE(create='[is1_muscl, is2_muscl, is3_muscl]') + + !> @name The cell-average variables that will be MUSCL-reconstructed. Formerly, they are stored in v_vf. However, they are + !! transferred to v_rs_wsL and v_rs_wsR as to be reshaped (RS) and/or characteristically decomposed. The reshaping allows the + !! muscl procedure to be independent of the coordinate direction of the reconstruction. Lastly, notice that the left (L) and + !! right (R) results of the characteristic decomposition are stored in custom-constructed muscl- stencils (WS) that are annexed + !! to each position of a given scalar field. !> @{ - real(wp), allocatable, dimension(:, :, :, :) :: v_rs_ws_x_muscl, v_rs_ws_y_muscl, v_rs_ws_z_muscl + real(wp), allocatable, dimension(:,:,:,:) :: v_rs_ws_x_muscl, v_rs_ws_y_muscl, v_rs_ws_z_muscl !> @} - $:GPU_DECLARE(create='[v_rs_ws_x_muscl,v_rs_ws_y_muscl,v_rs_ws_z_muscl]') - + $:GPU_DECLARE(create='[v_rs_ws_x_muscl, v_rs_ws_y_muscl, v_rs_ws_z_muscl]') contains subroutine s_initialize_muscl_module() - ! Initializing in x-direction is1_muscl%beg = -buff_size; is1_muscl%end = m - is1_muscl%beg if (n == 0) then is2_muscl%beg = 0 else - is2_muscl%beg = -buff_size; + is2_muscl%beg = -buff_size; end if is2_muscl%end = n - is2_muscl%beg @@ -66,8 +58,7 @@ contains is3_muscl%end = p - is3_muscl%beg - @:ALLOCATE(v_rs_ws_x_muscl(is1_muscl%beg:is1_muscl%end, & - is2_muscl%beg:is2_muscl%end, is3_muscl%beg:is3_muscl%end, 1:sys_size)) + @:ALLOCATE(v_rs_ws_x_muscl(is1_muscl%beg:is1_muscl%end, is2_muscl%beg:is2_muscl%end, is3_muscl%beg:is3_muscl%end, 1:sys_size)) if (n == 0) return @@ -83,8 +74,7 @@ contains is3_muscl%end = p - is3_muscl%beg - @:ALLOCATE(v_rs_ws_y_muscl(is2_muscl%beg:is2_muscl%end, & - is1_muscl%beg:is1_muscl%end, is3_muscl%beg:is3_muscl%end, 1:sys_size)) + @:ALLOCATE(v_rs_ws_y_muscl(is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, is3_muscl%beg:is3_muscl%end, 1:sys_size)) if (p == 0) return @@ -93,31 +83,24 @@ contains is1_muscl%beg = -buff_size; is1_muscl%end = m - is1_muscl%beg is3_muscl%beg = -buff_size; is3_muscl%end = p - is3_muscl%beg - @:ALLOCATE(v_rs_ws_z_muscl(is3_muscl%beg:is3_muscl%end, & - is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, 1:sys_size)) - + @:ALLOCATE(v_rs_ws_z_muscl(is3_muscl%beg:is3_muscl%end, is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, 1:sys_size)) end subroutine s_initialize_muscl_module - !> @brief Performs MUSCL reconstruction of left and right cell-boundary values from cell-averaged variables. - subroutine s_muscl(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, & - muscl_dir, & - is1_muscl_d, is2_muscl_d, is3_muscl_d) - - type(scalar_field), dimension(1:), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: & - vL_rs_vf_x, vL_rs_vf_y, & - vL_rs_vf_z, vR_rs_vf_x, & - vR_rs_vf_y, vR_rs_vf_z - integer, intent(in) :: muscl_dir - type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d + subroutine s_muscl(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, is1_muscl_d, & + & is2_muscl_d, is3_muscl_d) - integer :: j, k, l, i - real(wp) :: slopeL, slopeR, slope + type(scalar_field), dimension(1:), intent(in) :: v_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & + & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + integer, intent(in) :: muscl_dir + type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d + integer :: j, k, l, i + real(wp) :: slopeL, slopeR, slope is1_muscl = is1_muscl_d is2_muscl = is2_muscl_d is3_muscl = is3_muscl_d - $:GPU_UPDATE(device='[is1_muscl,is2_muscl,is3_muscl]') + $:GPU_UPDATE(device='[is1_muscl, is2_muscl, is3_muscl]') if (muscl_order /= 1 .or. dummy) then call s_initialize_muscl(v_vf, muscl_dir) @@ -138,7 +121,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() else if (muscl_dir == 2) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = 1, ubound(v_vf, 1) do l = is3_muscl%beg, is3_muscl%end do k = is2_muscl%beg, is2_muscl%end @@ -151,7 +134,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() else if (muscl_dir == 3) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = 1, ubound(v_vf, 1) do l = is3_muscl%beg, is3_muscl%end do k = is2_muscl%beg, is2_muscl%end @@ -170,16 +153,13 @@ contains ! MUSCL Reconstruction #:for MUSCL_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (muscl_dir == ${MUSCL_DIR}$) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[i,j,k,l,slopeL,slopeR,slope]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[i, j, k, l, slopeL, slopeR, slope]') do l = is3_muscl%beg, is3_muscl%end do k = is2_muscl%beg, is2_muscl%end do j = is1_muscl%beg, is1_muscl%end do i = 1, v_size - - slopeL = v_rs_ws_${XYZ}$_muscl(j + 1, k, l, i) - & - v_rs_ws_${XYZ}$_muscl(j, k, l, i) - slopeR = v_rs_ws_${XYZ}$_muscl(j, k, l, i) - & - v_rs_ws_${XYZ}$_muscl(j - 1, k, l, i) + slopeL = v_rs_ws_${XYZ}$_muscl(j + 1, k, l, i) - v_rs_ws_${XYZ}$_muscl(j, k, l, i) + slopeR = v_rs_ws_${XYZ}$_muscl(j, k, l, i) - v_rs_ws_${XYZ}$_muscl(j - 1, k, l, i) slope = 0._wp if (muscl_lim == 1) then ! minmod @@ -187,35 +167,33 @@ contains slope = min(abs(slopeL), abs(slopeR)) end if if (slopeL < 0._wp) slope = -slope - elseif (muscl_lim == 2) then ! MC + else if (muscl_lim == 2) then ! MC if (slopeL*slopeR > 1e-9_wp) then slope = min(2._wp*abs(slopeL), 2._wp*abs(slopeR)) slope = min(slope, 5e-1_wp*(abs(slopeL) + abs(slopeR))) end if if (slopeL < 0._wp) slope = -slope - elseif (muscl_lim == 3) then ! Van Albada - if (abs(slopeL) > 1e-6_wp .and. abs(slopeR) > 1e-6_wp .and. & - abs(slopeL + slopeR) > 1e-6_wp .and. slopeL*slopeR > 1e-6_wp) then + else if (muscl_lim == 3) then ! Van Albada + if (abs(slopeL) > 1e-6_wp .and. abs(slopeR) > 1e-6_wp .and. abs(slopeL + slopeR) & + & > 1e-6_wp .and. slopeL*slopeR > 1e-6_wp) then slope = ((slopeL + slopeR)*slopeL*slopeR)/(slopeL**2._wp + slopeR**2._wp) end if - elseif (muscl_lim == 4) then ! Van Leer + else if (muscl_lim == 4) then ! Van Leer if (abs(slopeL + slopeR) > 1.e-6_wp .and. slopeL*slopeR > 1.e-6_wp) then slope = 2._wp*slopeL*slopeR/(slopeL + slopeR) end if - elseif (muscl_lim == 5) then ! SUPERBEE + else if (muscl_lim == 5) then ! SUPERBEE if (slopeL*slopeR > 1e-6_wp) then - slope = -1._wp*min(-min(2._wp*abs(slopeL), abs(slopeR)), -min(abs(slopeL), 2._wp*abs(slopeR))) + slope = -1._wp*min(-min(2._wp*abs(slopeL), abs(slopeR)), -min(abs(slopeL), & + & 2._wp*abs(slopeR))) end if end if ! reconstruct from left side - vL_rs_vf_${XYZ}$ (j, k, l, i) = & - v_rs_ws_${XYZ}$_muscl(j, k, l, i) - (5.e-1_wp*slope) + vL_rs_vf_${XYZ}$ (j, k, l, i) = v_rs_ws_${XYZ}$_muscl(j, k, l, i) - (5.e-1_wp*slope) ! reconstruct from the right side - vR_rs_vf_${XYZ}$ (j, k, l, i) = & - v_rs_ws_${XYZ}$_muscl(j, k, l, i) + (5.e-1_wp*slope) - + vR_rs_vf_${XYZ}$ (j, k, l, i) = v_rs_ws_${XYZ}$_muscl(j, k, l, i) + (5.e-1_wp*slope) end do end do end do @@ -226,37 +204,27 @@ contains end if if (int_comp) then - call s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, & - vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, & - muscl_dir, is1_muscl_d, is2_muscl_d, is3_muscl_d) + call s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, & + & is1_muscl_d, is2_muscl_d, is3_muscl_d) end if - end subroutine s_muscl - !> @brief Applies THINC interface-compression to sharpen volume-fraction reconstructions at material interfaces. - subroutine s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, & - muscl_dir, & - is1_muscl_d, is2_muscl_d, is3_muscl_d) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: & - vL_rs_vf_x, vL_rs_vf_y, & - vL_rs_vf_z, vR_rs_vf_x, & - vR_rs_vf_y, vR_rs_vf_z - integer, intent(in) :: muscl_dir - type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d - - integer :: j, k, l + subroutine s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, & + & is1_muscl_d, is2_muscl_d, is3_muscl_d) - real(wp) :: aCL, aCR, aC, aTHINC, qmin, qmax, A, B, C, sign, moncon + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & + & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + integer, intent(in) :: muscl_dir + type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d + integer :: j, k, l + real(wp) :: aCL, aCR, aC, aTHINC, qmin, qmax, A, B, C, sign, moncon #:for MUSCL_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (muscl_dir == ${MUSCL_DIR}$) then - - $:GPU_PARALLEL_LOOP(collapse=3,private='[j,k,l,aCL,aC,aCR,aTHINC,moncon,sign,qmin,qmax]') + $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, aCL, aC, aCR, aTHINC, moncon, sign, qmin, qmax]') do l = is3_muscl%beg, is3_muscl%end do k = is2_muscl%beg, is2_muscl%end do j = is1_muscl%beg, is1_muscl%end - aCL = v_rs_ws_${XYZ}$_muscl(j - 1, k, l, advxb) aC = v_rs_ws_${XYZ}$_muscl(j, k, l, advxb) aCR = v_rs_ws_${XYZ}$_muscl(j + 1, k, l, advxb) @@ -282,10 +250,10 @@ contains aTHINC = qmin + 5e-1_wp*qmax*(1._wp + sign*A) if (aTHINC < ic_eps) aTHINC = ic_eps if (aTHINC > 1 - ic_eps) aTHINC = 1 - ic_eps - vL_rs_vf_${XYZ}$ (j, k, l, contxb) = vL_rs_vf_${XYZ}$ (j, k, l, contxb)/ & - vL_rs_vf_${XYZ}$ (j, k, l, advxb)*aTHINC - vL_rs_vf_${XYZ}$ (j, k, l, contxe) = vL_rs_vf_${XYZ}$ (j, k, l, contxe)/ & - (1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) + vL_rs_vf_${XYZ}$ (j, k, l, contxb) = vL_rs_vf_${XYZ}$ (j, k, l, contxb)/vL_rs_vf_${XYZ}$ (j, k, & + & l, advxb)*aTHINC + vL_rs_vf_${XYZ}$ (j, k, l, contxe) = vL_rs_vf_${XYZ}$ (j, k, l, & + & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) vL_rs_vf_${XYZ}$ (j, k, l, advxb) = aTHINC vL_rs_vf_${XYZ}$ (j, k, l, advxe) = 1 - aTHINC @@ -293,31 +261,25 @@ contains aTHINC = qmin + 5e-1_wp*qmax*(1._wp + sign*(tanh(ic_beta) + A)/(1._wp + A*tanh(ic_beta))) if (aTHINC < ic_eps) aTHINC = ic_eps if (aTHINC > 1 - ic_eps) aTHINC = 1 - ic_eps - vR_rs_vf_${XYZ}$ (j, k, l, contxb) = vL_rs_vf_${XYZ}$ (j, k, l, contxb)/ & - vL_rs_vf_${XYZ}$ (j, k, l, advxb)*aTHINC - vR_rs_vf_${XYZ}$ (j, k, l, contxe) = vL_rs_vf_${XYZ}$ (j, k, l, contxe)/ & - (1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) + vR_rs_vf_${XYZ}$ (j, k, l, contxb) = vL_rs_vf_${XYZ}$ (j, k, l, contxb)/vL_rs_vf_${XYZ}$ (j, k, & + & l, advxb)*aTHINC + vR_rs_vf_${XYZ}$ (j, k, l, contxe) = vL_rs_vf_${XYZ}$ (j, k, l, & + & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) vR_rs_vf_${XYZ}$ (j, k, l, advxb) = aTHINC vR_rs_vf_${XYZ}$ (j, k, l, advxe) = 1 - aTHINC - end if - end do end do end do $:END_GPU_PARALLEL_LOOP() end if #:endfor - end subroutine s_interface_compression - !> @brief Reshapes cell-averaged variable data into direction-local work arrays for MUSCL reconstruction. subroutine s_initialize_muscl(v_vf, muscl_dir) - type(scalar_field), dimension(:), intent(in) :: v_vf - integer, intent(in) :: muscl_dir - - integer :: j, k, l, q !< Generic loop iterators + integer, intent(in) :: muscl_dir + integer :: j, k, l, q !< Generic loop iterators ! Determining the number of cell-average variables which will be ! muscl-reconstructed and mapping their indical bounds in the x-, @@ -328,7 +290,7 @@ contains $:GPU_UPDATE(device='[v_size]') if (muscl_dir == 1) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,q]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, q]', collapse=4) do j = 1, v_size do q = is3_muscl%beg, is3_muscl%end do l = is2_muscl%beg, is2_muscl%end @@ -345,7 +307,7 @@ contains if (n == 0) return if (muscl_dir == 2) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,q]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, q]', collapse=4) do j = 1, v_size do q = is3_muscl%beg, is3_muscl%end do l = is2_muscl%beg, is2_muscl%end @@ -361,7 +323,7 @@ contains ! Reshaping/Projecting onto Characteristic Fields in z-direction if (p == 0) return if (muscl_dir == 3) then - $:GPU_PARALLEL_LOOP(private='[j,k,l,q]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[j, k, l, q]', collapse=4) do j = 1, v_size do q = is3_muscl%beg, is3_muscl%end do l = is2_muscl%beg, is2_muscl%end @@ -373,12 +335,9 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_initialize_muscl - !> @brief Deallocates the MUSCL direction-local work arrays. subroutine s_finalize_muscl_module() - @:DEALLOCATE(v_rs_ws_x_muscl) if (n == 0) return @@ -388,6 +347,5 @@ contains if (p == 0) return @:DEALLOCATE(v_rs_ws_z_muscl) - end subroutine s_finalize_muscl_module end module m_muscl diff --git a/src/simulation/m_pressure_relaxation.fpp b/src/simulation/m_pressure_relaxation.fpp index 69689de06c..1dfb597340 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -5,26 +5,23 @@ #:include 'case.fpp' #:include 'macros.fpp' -!> @brief Pressure relaxation for the six-equation multi-component model via Newton--Raphson equilibration and volume-fraction correction +!> @brief Pressure relaxation for the six-equation multi-component model via Newton--Raphson equilibration and volume-fraction +!! correction module m_pressure_relaxation - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters implicit none - private; public :: s_pressure_relaxation_procedure, & - s_initialize_pressure_relaxation_module, & - s_finalize_pressure_relaxation_module + private; public :: s_pressure_relaxation_procedure, s_initialize_pressure_relaxation_module, & + & s_finalize_pressure_relaxation_module - real(wp), allocatable, dimension(:, :) :: Res_pr + real(wp), allocatable, dimension(:,:) :: Res_pr $:GPU_DECLARE(create='[Res_pr]') - contains !> Initialize the pressure relaxation module impure subroutine s_initialize_pressure_relaxation_module - integer :: i, j if (viscous) then @@ -36,26 +33,20 @@ contains end do $:GPU_UPDATE(device='[Res_pr, Re_idx, Re_size]') end if - end subroutine s_initialize_pressure_relaxation_module - !> Finalize the pressure relaxation module impure subroutine s_finalize_pressure_relaxation_module - if (viscous) then @:DEALLOCATE(Res_pr) end if - end subroutine s_finalize_pressure_relaxation_module - !> The main pressure relaxation procedure !! @param q_cons_vf Cell-average conservative variables subroutine s_pressure_relaxation_procedure(q_cons_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer :: j, k, l + integer :: j, k, l - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m @@ -64,15 +55,13 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_pressure_relaxation_procedure - !> Process pressure relaxation for a single cell subroutine s_relax_cell_pressure(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer, intent(in) :: j, k, l + integer, intent(in) :: j, k, l ! Volume fraction correction if (mpp_lim) call s_correct_volume_fractions(q_cons_vf, j, k, l) @@ -84,16 +73,14 @@ contains ! Internal energy correction call s_correct_internal_energies(q_cons_vf, j, k, l) - end subroutine s_relax_cell_pressure - !> Check if pressure relaxation is needed for this cell logical function s_needs_pressure_relaxation(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - integer, intent(in) :: j, k, l - integer :: i + integer, intent(in) :: j, k, l + integer :: i s_needs_pressure_relaxation = .true. $:GPU_LOOP(parallelism='[seq]') @@ -102,29 +89,25 @@ contains s_needs_pressure_relaxation = .false. end if end do - end function s_needs_pressure_relaxation - !> Correct volume fractions to physical bounds subroutine s_correct_volume_fractions(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer, intent(in) :: j, k, l - real(wp) :: sum_alpha - integer :: i + integer, intent(in) :: j, k, l + real(wp) :: sum_alpha + integer :: i sum_alpha = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - if ((q_cons_vf(i + contxb - 1)%sf(j, k, l) < 0._wp) .or. & - (q_cons_vf(i + advxb - 1)%sf(j, k, l) < 0._wp)) then + if ((q_cons_vf(i + contxb - 1)%sf(j, k, l) < 0._wp) .or. (q_cons_vf(i + advxb - 1)%sf(j, k, l) < 0._wp)) then q_cons_vf(i + contxb - 1)%sf(j, k, l) = 0._wp q_cons_vf(i + advxb - 1)%sf(j, k, l) = 0._wp q_cons_vf(i + intxb - 1)%sf(j, k, l) = 0._wp end if - if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > 1._wp) & - q_cons_vf(i + advxb - 1)%sf(j, k, l) = 1._wp + if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > 1._wp) q_cons_vf(i + advxb - 1)%sf(j, k, l) = 1._wp sum_alpha = sum_alpha + q_cons_vf(i + advxb - 1)%sf(j, k, l) end do @@ -132,35 +115,31 @@ contains do i = 1, num_fluids q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, l)/sum_alpha end do - end subroutine s_correct_volume_fractions - !> Main pressure equilibration using Newton-Raphson subroutine s_equilibrate_pressure(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer, intent(in) :: j, k, l - - real(wp) :: pres_relax, f_pres, df_pres + integer, intent(in) :: j, k, l + real(wp) :: pres_relax, f_pres, df_pres #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: pres_K_init, rho_K_s #:else real(wp), dimension(num_fluids) :: pres_K_init, rho_K_s #:endif - integer, parameter :: MAX_ITER = 50 + integer, parameter :: MAX_ITER = 50 real(wp), parameter :: TOLERANCE = 1.e-10_wp - integer :: iter, i + integer :: iter, i ! Initialize pressures pres_relax = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then - pres_K_init(i) = (q_cons_vf(i + intxb - 1)%sf(j, k, l)/ & - q_cons_vf(i + advxb - 1)%sf(j, k, l) - pi_infs(i))/gammas(i) - if (pres_K_init(i) <= -(1._wp - 1.e-8_wp)*ps_inf(i) + 1.e-8_wp) & - pres_K_init(i) = -(1._wp - 1.e-8_wp)*ps_inf(i) + 1.e-8_wp + pres_K_init(i) = (q_cons_vf(i + intxb - 1)%sf(j, k, l)/q_cons_vf(i + advxb - 1)%sf(j, k, l) - pi_infs(i))/gammas(i) + if (pres_K_init(i) <= -(1._wp - 1.e-8_wp)*ps_inf(i) + 1.e-8_wp) pres_K_init(i) = -(1._wp - 1.e-8_wp)*ps_inf(i) & + & + 1.e-8_wp else pres_K_init(i) = 0._wp end if @@ -177,8 +156,8 @@ contains ! Enforce pressure bounds do i = 1, num_fluids - if (pres_relax <= -(1._wp - 1.e-8_wp)*ps_inf(i) + 1.e-8_wp) & - pres_relax = -(1._wp - 1.e-8_wp)*ps_inf(i) + 1.e-8_wp + if (pres_relax <= -(1._wp - 1.e-8_wp)*ps_inf(i) + 1.e-8_wp) pres_relax = -(1._wp - 1.e-8_wp)*ps_inf(i) & + & + 1.e-8_wp end do ! Newton-Raphson step @@ -187,13 +166,10 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then - rho_K_s(i) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/ & - max(q_cons_vf(i + advxb - 1)%sf(j, k, l), sgm_eps) & - *((pres_relax + ps_inf(i))/(pres_K_init(i) + & - ps_inf(i)))**(1._wp/gs_min(i)) + rho_K_s(i) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/max(q_cons_vf(i + advxb - 1)%sf(j, k, l), & + & sgm_eps)*((pres_relax + ps_inf(i))/(pres_K_init(i) + ps_inf(i)))**(1._wp/gs_min(i)) f_pres = f_pres + q_cons_vf(i + contxb - 1)%sf(j, k, l)/rho_K_s(i) - df_pres = df_pres - q_cons_vf(i + contxb - 1)%sf(j, k, l) & - /(gs_min(i)*rho_K_s(i)*(pres_relax + ps_inf(i))) + df_pres = df_pres - q_cons_vf(i + contxb - 1)%sf(j, k, l)/(gs_min(i)*rho_K_s(i)*(pres_relax + ps_inf(i))) end if end do end if @@ -202,26 +178,24 @@ contains ! Update volume fractions $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) & - q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/rho_K_s(i) + if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) q_cons_vf(i + advxb - 1)%sf(j, k, & + & l) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/rho_K_s(i) end do - end subroutine s_equilibrate_pressure - !> Correct internal energies using equilibrated pressure subroutine s_correct_internal_energies(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer, intent(in) :: j, k, l + integer, intent(in) :: j, k, l #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(2) :: alpha_rho, alpha #:else real(wp), dimension(num_fluids) :: alpha_rho, alpha #:endif - real(wp) :: rho, dyn_pres, gamma, pi_inf, pres_relax, sum_alpha + real(wp) :: rho, dyn_pres, gamma, pi_inf, pres_relax, sum_alpha real(wp), dimension(2) :: Re - integer :: i, q + integer :: i, q $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids @@ -291,18 +265,14 @@ contains dyn_pres = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = momxb, momxe - dyn_pres = dyn_pres + 5.e-1_wp*q_cons_vf(i)%sf(j, k, l)* & - q_cons_vf(i)%sf(j, k, l)/max(rho, sgm_eps) + dyn_pres = dyn_pres + 5.e-1_wp*q_cons_vf(i)%sf(j, k, l)*q_cons_vf(i)%sf(j, k, l)/max(rho, sgm_eps) end do pres_relax = (q_cons_vf(E_idx)%sf(j, k, l) - dyn_pres - pi_inf)/gamma $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - q_cons_vf(i + intxb - 1)%sf(j, k, l) = & - q_cons_vf(i + advxb - 1)%sf(j, k, l)*(gammas(i)*pres_relax + pi_infs(i)) + q_cons_vf(i + intxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, l)*(gammas(i)*pres_relax + pi_infs(i)) end do - end subroutine s_correct_internal_energies - end module m_pressure_relaxation diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index d081b8f83e..07b1807a4b 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -7,7 +7,6 @@ !> @brief Quadrature-based moment methods (QBMM) for polydisperse bubble moment inversion and transport module m_qbmm - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -24,7 +23,7 @@ module m_qbmm private; public :: s_initialize_qbmm_module, s_mom_inv, s_coeff, s_compute_qbmm_rhs - real(wp), allocatable, dimension(:, :, :, :, :) :: momrhs + real(wp), allocatable, dimension(:,:,:,:,:) :: momrhs $:GPU_DECLARE(create='[momrhs]') #:if MFC_CASE_OPTIMIZATION @@ -35,21 +34,18 @@ module m_qbmm #:endif type(int_bounds_info) :: is1_qbmm, is2_qbmm, is3_qbmm - $:GPU_DECLARE(create='[is1_qbmm,is2_qbmm,is3_qbmm]') - - integer, allocatable, dimension(:) :: bubrs_qbmm - integer, allocatable, dimension(:, :) :: bubmoms - $:GPU_DECLARE(create='[bubrs_qbmm,bubmoms]') + $:GPU_DECLARE(create='[is1_qbmm, is2_qbmm, is3_qbmm]') + integer, allocatable, dimension(:) :: bubrs_qbmm + integer, allocatable, dimension(:,:) :: bubmoms + $:GPU_DECLARE(create='[bubrs_qbmm, bubmoms]') contains !> @brief Allocates and initializes moment coefficient arrays for the QBMM module. impure subroutine s_initialize_qbmm_module - integer :: i1, i2, q, i, j #:if not MFC_CASE_OPTIMIZATION - if (bubble_model == 2) then ! Keller-Miksis without viscosity/surface tension nterms = 32 @@ -60,7 +56,6 @@ contains $:GPU_ENTER_DATA(copyin='[nterms]') $:GPU_UPDATE(device='[nterms]') - #:endif @:ALLOCATE(momrhs(1:3, 0:2, 0:2, 1:nterms, 1:nb)) @@ -72,324 +67,320 @@ contains if (.not. polytropic) then do q = 1, nb do i1 = 0, 2; do i2 = 0, 2 - if ((i1 + i2) <= 2) then - if (bubble_model == 3) then - momrhs(1, i1, i2, 1, q) = -1._wp + i1 - momrhs(2, i1, i2, 1, q) = -1._wp + i2 - momrhs(3, i1, i2, 1, q) = 0._wp - - momrhs(1, i1, i2, 2, q) = -1._wp + i1 - momrhs(2, i1, i2, 2, q) = 1._wp + i2 - momrhs(3, i1, i2, 2, q) = 0._wp - - momrhs(1, i1, i2, 3, q) = -1._wp + i1 - momrhs(2, i1, i2, 3, q) = -1._wp + i2 - momrhs(3, i1, i2, 3, q) = 0._wp - - momrhs(1, i1, i2, 4, q) = -1._wp + i1 - momrhs(2, i1, i2, 4, q) = 1._wp + i2 - momrhs(3, i1, i2, 4, q) = 0._wp - - if (.not. f_is_default(Re_inv)) then - ! add viscosity - momrhs(1, i1, i2, 5, q) = -2._wp + i1 - momrhs(2, i1, i2, 5, q) = i2 - momrhs(3, i1, i2, 5, q) = 0._wp - end if + if ((i1 + i2) <= 2) then + if (bubble_model == 3) then + momrhs(1, i1, i2, 1, q) = -1._wp + i1 + momrhs(2, i1, i2, 1, q) = -1._wp + i2 + momrhs(3, i1, i2, 1, q) = 0._wp - if (.not. f_is_default(Web)) then - ! add surface tension - momrhs(1, i1, i2, 6, q) = -2._wp + i1 - momrhs(2, i1, i2, 6, q) = -1._wp + i2 - momrhs(3, i1, i2, 6, q) = 0._wp - end if + momrhs(1, i1, i2, 2, q) = -1._wp + i1 + momrhs(2, i1, i2, 2, q) = 1._wp + i2 + momrhs(3, i1, i2, 2, q) = 0._wp - momrhs(1, i1, i2, 7, q) = -1._wp + i1 - momrhs(2, i1, i2, 7, q) = -1._wp + i2 - momrhs(3, i1, i2, 7, q) = 0._wp + momrhs(1, i1, i2, 3, q) = -1._wp + i1 + momrhs(2, i1, i2, 3, q) = -1._wp + i2 + momrhs(3, i1, i2, 3, q) = 0._wp - else if (bubble_model == 2) then - ! KM with approximation of 1/(1-V/C) = 1+V/C - momrhs(1, i1, i2, 1, q) = -1._wp + i1 - momrhs(2, i1, i2, 1, q) = 1._wp + i2 - momrhs(3, i1, i2, 1, q) = 0._wp + momrhs(1, i1, i2, 4, q) = -1._wp + i1 + momrhs(2, i1, i2, 4, q) = 1._wp + i2 + momrhs(3, i1, i2, 4, q) = 0._wp - momrhs(1, i1, i2, 2, q) = -1._wp + i1 - momrhs(2, i1, i2, 2, q) = 2._wp + i2 - momrhs(3, i1, i2, 2, q) = 0._wp - - momrhs(1, i1, i2, 3, q) = -1._wp + i1 - momrhs(2, i1, i2, 3, q) = 3._wp + i2 - momrhs(3, i1, i2, 3, q) = 0._wp - - momrhs(1, i1, i2, 4, q) = -1._wp + i1 - momrhs(2, i1, i2, 4, q) = -1._wp + i2 - momrhs(3, i1, i2, 4, q) = 0._wp - - momrhs(1, i1, i2, 5, q) = -1._wp + i1 + if (.not. f_is_default(Re_inv)) then + ! add viscosity + momrhs(1, i1, i2, 5, q) = -2._wp + i1 momrhs(2, i1, i2, 5, q) = i2 momrhs(3, i1, i2, 5, q) = 0._wp + end if - momrhs(1, i1, i2, 6, q) = -1._wp + i1 - momrhs(2, i1, i2, 6, q) = 1._wp + i2 + if (.not. f_is_default(Web)) then + ! add surface tension + momrhs(1, i1, i2, 6, q) = -2._wp + i1 + momrhs(2, i1, i2, 6, q) = -1._wp + i2 momrhs(3, i1, i2, 6, q) = 0._wp + end if - momrhs(1, i1, i2, 7, q) = -1._wp + i1 - momrhs(2, i1, i2, 7, q) = -1._wp + i2 - momrhs(3, i1, i2, 7, q) = 0._wp - - momrhs(1, i1, i2, 8, q) = -1._wp + i1 - momrhs(2, i1, i2, 8, q) = i2 - momrhs(3, i1, i2, 8, q) = 0._wp - - momrhs(1, i1, i2, 9, q) = -1._wp + i1 - momrhs(2, i1, i2, 9, q) = 1._wp + i2 - momrhs(3, i1, i2, 9, q) = 0._wp - - momrhs(1, i1, i2, 10, q) = -1._wp + i1 - momrhs(2, i1, i2, 10, q) = i2 - momrhs(3, i1, i2, 10, q) = 0._wp - - momrhs(1, i1, i2, 11, q) = -1._wp + i1 - momrhs(2, i1, i2, 11, q) = 1._wp + i2 - momrhs(3, i1, i2, 11, q) = 0._wp - - momrhs(1, i1, i2, 12, q) = -1._wp + i1 - momrhs(2, i1, i2, 12, q) = 1._wp + i2 - momrhs(3, i1, i2, 12, q) = 0._wp - - momrhs(1, i1, i2, 13, q) = -1._wp + i1 - momrhs(2, i1, i2, 13, q) = -1._wp + i2 - momrhs(3, i1, i2, 13, q) = 0._wp - - momrhs(1, i1, i2, 14, q) = -1._wp + i1 - momrhs(2, i1, i2, 14, q) = i2 - momrhs(3, i1, i2, 14, q) = 0._wp - - momrhs(1, i1, i2, 15, q) = -1._wp + i1 - momrhs(2, i1, i2, 15, q) = 1._wp + i2 - momrhs(3, i1, i2, 15, q) = 0._wp - - momrhs(1, i1, i2, 16, q) = -2._wp + i1 - momrhs(2, i1, i2, 16, q) = i2 - momrhs(3, i1, i2, 16, q) = 0._wp - - momrhs(1, i1, i2, 17, q) = -2._wp + i1 - momrhs(2, i1, i2, 17, q) = -1._wp + i2 - momrhs(3, i1, i2, 17, q) = 0._wp - - momrhs(1, i1, i2, 18, q) = -2._wp + i1 - momrhs(2, i1, i2, 18, q) = 1._wp + i2 - momrhs(3, i1, i2, 18, q) = 0._wp - - momrhs(1, i1, i2, 19, q) = -2._wp + i1 - momrhs(2, i1, i2, 19, q) = 2._wp + i2 - momrhs(3, i1, i2, 19, q) = 0._wp - - momrhs(1, i1, i2, 20, q) = -2._wp + i1 - momrhs(2, i1, i2, 20, q) = -1._wp + i2 - momrhs(3, i1, i2, 20, q) = 0._wp + momrhs(1, i1, i2, 7, q) = -1._wp + i1 + momrhs(2, i1, i2, 7, q) = -1._wp + i2 + momrhs(3, i1, i2, 7, q) = 0._wp + else if (bubble_model == 2) then + ! KM with approximation of 1/(1-V/C) = 1+V/C + momrhs(1, i1, i2, 1, q) = -1._wp + i1 + momrhs(2, i1, i2, 1, q) = 1._wp + i2 + momrhs(3, i1, i2, 1, q) = 0._wp - momrhs(1, i1, i2, 21, q) = -2._wp + i1 - momrhs(2, i1, i2, 21, q) = i2 - momrhs(3, i1, i2, 21, q) = 0._wp + momrhs(1, i1, i2, 2, q) = -1._wp + i1 + momrhs(2, i1, i2, 2, q) = 2._wp + i2 + momrhs(3, i1, i2, 2, q) = 0._wp - momrhs(1, i1, i2, 22, q) = -2._wp + i1 - momrhs(2, i1, i2, 22, q) = -1._wp + i2 - momrhs(3, i1, i2, 22, q) = 0._wp + momrhs(1, i1, i2, 3, q) = -1._wp + i1 + momrhs(2, i1, i2, 3, q) = 3._wp + i2 + momrhs(3, i1, i2, 3, q) = 0._wp - momrhs(1, i1, i2, 23, q) = -2._wp + i1 - momrhs(2, i1, i2, 23, q) = i2 - momrhs(3, i1, i2, 23, q) = 0._wp + momrhs(1, i1, i2, 4, q) = -1._wp + i1 + momrhs(2, i1, i2, 4, q) = -1._wp + i2 + momrhs(3, i1, i2, 4, q) = 0._wp - momrhs(1, i1, i2, 24, q) = -3._wp + i1 - momrhs(2, i1, i2, 24, q) = i2 - momrhs(3, i1, i2, 24, q) = 0._wp + momrhs(1, i1, i2, 5, q) = -1._wp + i1 + momrhs(2, i1, i2, 5, q) = i2 + momrhs(3, i1, i2, 5, q) = 0._wp - momrhs(1, i1, i2, 25, q) = -3._wp + i1 - momrhs(2, i1, i2, 25, q) = -1._wp + i2 - momrhs(3, i1, i2, 25, q) = 0._wp + momrhs(1, i1, i2, 6, q) = -1._wp + i1 + momrhs(2, i1, i2, 6, q) = 1._wp + i2 + momrhs(3, i1, i2, 6, q) = 0._wp - momrhs(1, i1, i2, 26, q) = -2._wp + i1 - momrhs(2, i1, i2, 26, q) = i2 - momrhs(3, i1, i2, 26, q) = 0._wp + momrhs(1, i1, i2, 7, q) = -1._wp + i1 + momrhs(2, i1, i2, 7, q) = -1._wp + i2 + momrhs(3, i1, i2, 7, q) = 0._wp + + momrhs(1, i1, i2, 8, q) = -1._wp + i1 + momrhs(2, i1, i2, 8, q) = i2 + momrhs(3, i1, i2, 8, q) = 0._wp + + momrhs(1, i1, i2, 9, q) = -1._wp + i1 + momrhs(2, i1, i2, 9, q) = 1._wp + i2 + momrhs(3, i1, i2, 9, q) = 0._wp + + momrhs(1, i1, i2, 10, q) = -1._wp + i1 + momrhs(2, i1, i2, 10, q) = i2 + momrhs(3, i1, i2, 10, q) = 0._wp + + momrhs(1, i1, i2, 11, q) = -1._wp + i1 + momrhs(2, i1, i2, 11, q) = 1._wp + i2 + momrhs(3, i1, i2, 11, q) = 0._wp + + momrhs(1, i1, i2, 12, q) = -1._wp + i1 + momrhs(2, i1, i2, 12, q) = 1._wp + i2 + momrhs(3, i1, i2, 12, q) = 0._wp + + momrhs(1, i1, i2, 13, q) = -1._wp + i1 + momrhs(2, i1, i2, 13, q) = -1._wp + i2 + momrhs(3, i1, i2, 13, q) = 0._wp + + momrhs(1, i1, i2, 14, q) = -1._wp + i1 + momrhs(2, i1, i2, 14, q) = i2 + momrhs(3, i1, i2, 14, q) = 0._wp + + momrhs(1, i1, i2, 15, q) = -1._wp + i1 + momrhs(2, i1, i2, 15, q) = 1._wp + i2 + momrhs(3, i1, i2, 15, q) = 0._wp + + momrhs(1, i1, i2, 16, q) = -2._wp + i1 + momrhs(2, i1, i2, 16, q) = i2 + momrhs(3, i1, i2, 16, q) = 0._wp + + momrhs(1, i1, i2, 17, q) = -2._wp + i1 + momrhs(2, i1, i2, 17, q) = -1._wp + i2 + momrhs(3, i1, i2, 17, q) = 0._wp + + momrhs(1, i1, i2, 18, q) = -2._wp + i1 + momrhs(2, i1, i2, 18, q) = 1._wp + i2 + momrhs(3, i1, i2, 18, q) = 0._wp + + momrhs(1, i1, i2, 19, q) = -2._wp + i1 + momrhs(2, i1, i2, 19, q) = 2._wp + i2 + momrhs(3, i1, i2, 19, q) = 0._wp + + momrhs(1, i1, i2, 20, q) = -2._wp + i1 + momrhs(2, i1, i2, 20, q) = -1._wp + i2 + momrhs(3, i1, i2, 20, q) = 0._wp + + momrhs(1, i1, i2, 21, q) = -2._wp + i1 + momrhs(2, i1, i2, 21, q) = i2 + momrhs(3, i1, i2, 21, q) = 0._wp + + momrhs(1, i1, i2, 22, q) = -2._wp + i1 + momrhs(2, i1, i2, 22, q) = -1._wp + i2 + momrhs(3, i1, i2, 22, q) = 0._wp + + momrhs(1, i1, i2, 23, q) = -2._wp + i1 + momrhs(2, i1, i2, 23, q) = i2 + momrhs(3, i1, i2, 23, q) = 0._wp + + momrhs(1, i1, i2, 24, q) = -3._wp + i1 + momrhs(2, i1, i2, 24, q) = i2 + momrhs(3, i1, i2, 24, q) = 0._wp + + momrhs(1, i1, i2, 25, q) = -3._wp + i1 + momrhs(2, i1, i2, 25, q) = -1._wp + i2 + momrhs(3, i1, i2, 25, q) = 0._wp + + momrhs(1, i1, i2, 26, q) = -2._wp + i1 + momrhs(2, i1, i2, 26, q) = i2 + momrhs(3, i1, i2, 26, q) = 0._wp - momrhs(1, i1, i2, 27, q) = -1._wp + i1 - momrhs(2, i1, i2, 27, q) = -1._wp + i2 - momrhs(3, i1, i2, 27, q) = 0._wp + momrhs(1, i1, i2, 27, q) = -1._wp + i1 + momrhs(2, i1, i2, 27, q) = -1._wp + i2 + momrhs(3, i1, i2, 27, q) = 0._wp - momrhs(1, i1, i2, 28, q) = -1._wp + i1 - momrhs(2, i1, i2, 28, q) = i2 - momrhs(3, i1, i2, 28, q) = 0._wp + momrhs(1, i1, i2, 28, q) = -1._wp + i1 + momrhs(2, i1, i2, 28, q) = i2 + momrhs(3, i1, i2, 28, q) = 0._wp - momrhs(1, i1, i2, 29, q) = -2._wp + i1 - momrhs(2, i1, i2, 29, q) = i2 - momrhs(3, i1, i2, 29, q) = 0._wp + momrhs(1, i1, i2, 29, q) = -2._wp + i1 + momrhs(2, i1, i2, 29, q) = i2 + momrhs(3, i1, i2, 29, q) = 0._wp - momrhs(1, i1, i2, 30, q) = -1._wp + i1 - momrhs(2, i1, i2, 30, q) = -1._wp + i2 - momrhs(3, i1, i2, 30, q) = 0._wp + momrhs(1, i1, i2, 30, q) = -1._wp + i1 + momrhs(2, i1, i2, 30, q) = -1._wp + i2 + momrhs(3, i1, i2, 30, q) = 0._wp - momrhs(1, i1, i2, 31, q) = -1._wp + i1 - momrhs(2, i1, i2, 31, q) = i2 - momrhs(3, i1, i2, 31, q) = 0._wp + momrhs(1, i1, i2, 31, q) = -1._wp + i1 + momrhs(2, i1, i2, 31, q) = i2 + momrhs(3, i1, i2, 31, q) = 0._wp - momrhs(1, i1, i2, 32, q) = -2._wp + i1 - momrhs(2, i1, i2, 32, q) = i2 - momrhs(3, i1, i2, 32, q) = 0._wp - end if + momrhs(1, i1, i2, 32, q) = -2._wp + i1 + momrhs(2, i1, i2, 32, q) = i2 + momrhs(3, i1, i2, 32, q) = 0._wp end if - end do; end do + end if + end do; end do end do - else do q = 1, nb do i1 = 0, 2; do i2 = 0, 2 - if ((i1 + i2) <= 2) then - if (bubble_model == 3) then - momrhs(1, i1, i2, 1, q) = -1._wp + i1 - momrhs(2, i1, i2, 1, q) = -1._wp + i2 - momrhs(3, i1, i2, 1, q) = 0._wp - - momrhs(1, i1, i2, 2, q) = -1._wp + i1 - momrhs(2, i1, i2, 2, q) = 1._wp + i2 - momrhs(3, i1, i2, 2, q) = 0._wp - - momrhs(1, i1, i2, 3, q) = -1._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 3, q) = -1._wp + i2 - momrhs(3, i1, i2, 3, q) = 3._wp*gam - - momrhs(1, i1, i2, 4, q) = -1._wp + i1 - momrhs(2, i1, i2, 4, q) = 1._wp + i2 - momrhs(3, i1, i2, 4, q) = 0._wp - - if (.not. f_is_default(Re_inv)) then - ! add viscosity - momrhs(1, i1, i2, 5, q) = -2._wp + i1 - momrhs(2, i1, i2, 5, q) = i2 - momrhs(3, i1, i2, 5, q) = 0._wp - end if - - if (.not. f_is_default(Web)) then - ! add surface tension - momrhs(1, i1, i2, 6, q) = -2._wp + i1 - momrhs(2, i1, i2, 6, q) = -1._wp + i2 - momrhs(3, i1, i2, 6, q) = 0._wp - end if - - momrhs(1, i1, i2, 7, q) = -1._wp + i1 - momrhs(2, i1, i2, 7, q) = -1._wp + i2 - momrhs(3, i1, i2, 7, q) = 0._wp + if ((i1 + i2) <= 2) then + if (bubble_model == 3) then + momrhs(1, i1, i2, 1, q) = -1._wp + i1 + momrhs(2, i1, i2, 1, q) = -1._wp + i2 + momrhs(3, i1, i2, 1, q) = 0._wp - else if (bubble_model == 2) then - ! KM with approximation of 1/(1-V/C) = 1+V/C - momrhs(1, i1, i2, 1, q) = -1._wp + i1 - momrhs(2, i1, i2, 1, q) = 1._wp + i2 - momrhs(3, i1, i2, 1, q) = 0._wp + momrhs(1, i1, i2, 2, q) = -1._wp + i1 + momrhs(2, i1, i2, 2, q) = 1._wp + i2 + momrhs(3, i1, i2, 2, q) = 0._wp - momrhs(1, i1, i2, 2, q) = -1._wp + i1 - momrhs(2, i1, i2, 2, q) = 2._wp + i2 - momrhs(3, i1, i2, 2, q) = 0._wp + momrhs(1, i1, i2, 3, q) = -1._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 3, q) = -1._wp + i2 + momrhs(3, i1, i2, 3, q) = 3._wp*gam - momrhs(1, i1, i2, 3, q) = -1._wp + i1 - momrhs(2, i1, i2, 3, q) = 3._wp + i2 - momrhs(3, i1, i2, 3, q) = 0._wp + momrhs(1, i1, i2, 4, q) = -1._wp + i1 + momrhs(2, i1, i2, 4, q) = 1._wp + i2 + momrhs(3, i1, i2, 4, q) = 0._wp - momrhs(1, i1, i2, 4, q) = -1._wp + i1 - momrhs(2, i1, i2, 4, q) = -1._wp + i2 - momrhs(3, i1, i2, 4, q) = 0._wp - - momrhs(1, i1, i2, 5, q) = -1._wp + i1 + if (.not. f_is_default(Re_inv)) then + ! add viscosity + momrhs(1, i1, i2, 5, q) = -2._wp + i1 momrhs(2, i1, i2, 5, q) = i2 momrhs(3, i1, i2, 5, q) = 0._wp + end if - momrhs(1, i1, i2, 6, q) = -1._wp + i1 - momrhs(2, i1, i2, 6, q) = 1._wp + i2 + if (.not. f_is_default(Web)) then + ! add surface tension + momrhs(1, i1, i2, 6, q) = -2._wp + i1 + momrhs(2, i1, i2, 6, q) = -1._wp + i2 momrhs(3, i1, i2, 6, q) = 0._wp - - momrhs(1, i1, i2, 7, q) = -1._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 7, q) = -1._wp + i2 - momrhs(3, i1, i2, 7, q) = 3._wp*gam - - momrhs(1, i1, i2, 8, q) = -1._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 8, q) = i2 - momrhs(3, i1, i2, 8, q) = 3._wp*gam - - momrhs(1, i1, i2, 9, q) = -1._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 9, q) = 1._wp + i2 - momrhs(3, i1, i2, 9, q) = 3._wp*gam - - momrhs(1, i1, i2, 10, q) = -1._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 10, q) = i2 - momrhs(3, i1, i2, 10, q) = 3._wp*gam - - momrhs(1, i1, i2, 11, q) = -1._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 11, q) = 1._wp + i2 - momrhs(3, i1, i2, 11, q) = 3._wp*gam - - momrhs(1, i1, i2, 12, q) = -1._wp + i1 - momrhs(2, i1, i2, 12, q) = 1._wp + i2 - momrhs(3, i1, i2, 12, q) = 0._wp - - momrhs(1, i1, i2, 13, q) = -1._wp + i1 - momrhs(2, i1, i2, 13, q) = -1._wp + i2 - momrhs(3, i1, i2, 13, q) = 0._wp - - momrhs(1, i1, i2, 14, q) = -1._wp + i1 - momrhs(2, i1, i2, 14, q) = i2 - momrhs(3, i1, i2, 14, q) = 0._wp - - momrhs(1, i1, i2, 15, q) = -1._wp + i1 - momrhs(2, i1, i2, 15, q) = 1._wp + i2 - momrhs(3, i1, i2, 15, q) = 0._wp - - momrhs(1, i1, i2, 16, q) = -2._wp + i1 - momrhs(2, i1, i2, 16, q) = i2 - momrhs(3, i1, i2, 16, q) = 0._wp - - momrhs(1, i1, i2, 17, q) = -2._wp + i1 - momrhs(2, i1, i2, 17, q) = -1._wp + i2 - momrhs(3, i1, i2, 17, q) = 0._wp - - momrhs(1, i1, i2, 18, q) = -2._wp + i1 - momrhs(2, i1, i2, 18, q) = 1._wp + i2 - momrhs(3, i1, i2, 18, q) = 0._wp - - momrhs(1, i1, i2, 19, q) = -2._wp + i1 - momrhs(2, i1, i2, 19, q) = 2._wp + i2 - momrhs(3, i1, i2, 19, q) = 0._wp - - momrhs(1, i1, i2, 20, q) = -2._wp + i1 - momrhs(2, i1, i2, 20, q) = -1._wp + i2 - momrhs(3, i1, i2, 20, q) = 0._wp - - momrhs(1, i1, i2, 21, q) = -2._wp + i1 - momrhs(2, i1, i2, 21, q) = i2 - momrhs(3, i1, i2, 21, q) = 0._wp - - momrhs(1, i1, i2, 22, q) = -2._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 22, q) = -1._wp + i2 - momrhs(3, i1, i2, 22, q) = 3._wp*gam - - momrhs(1, i1, i2, 23, q) = -2._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 23, q) = i2 - momrhs(3, i1, i2, 23, q) = 3._wp*gam - - momrhs(1, i1, i2, 24, q) = -3._wp + i1 - momrhs(2, i1, i2, 24, q) = i2 - momrhs(3, i1, i2, 24, q) = 0._wp - - momrhs(1, i1, i2, 25, q) = -3._wp + i1 - momrhs(2, i1, i2, 25, q) = -1._wp + i2 - momrhs(3, i1, i2, 25, q) = 0._wp - - momrhs(1, i1, i2, 26, q) = -2._wp + i1 - 3._wp*gam - momrhs(2, i1, i2, 26, q) = i2 - momrhs(3, i1, i2, 26, q) = 3._wp*gam - end if + + momrhs(1, i1, i2, 7, q) = -1._wp + i1 + momrhs(2, i1, i2, 7, q) = -1._wp + i2 + momrhs(3, i1, i2, 7, q) = 0._wp + else if (bubble_model == 2) then + ! KM with approximation of 1/(1-V/C) = 1+V/C + momrhs(1, i1, i2, 1, q) = -1._wp + i1 + momrhs(2, i1, i2, 1, q) = 1._wp + i2 + momrhs(3, i1, i2, 1, q) = 0._wp + + momrhs(1, i1, i2, 2, q) = -1._wp + i1 + momrhs(2, i1, i2, 2, q) = 2._wp + i2 + momrhs(3, i1, i2, 2, q) = 0._wp + + momrhs(1, i1, i2, 3, q) = -1._wp + i1 + momrhs(2, i1, i2, 3, q) = 3._wp + i2 + momrhs(3, i1, i2, 3, q) = 0._wp + + momrhs(1, i1, i2, 4, q) = -1._wp + i1 + momrhs(2, i1, i2, 4, q) = -1._wp + i2 + momrhs(3, i1, i2, 4, q) = 0._wp + + momrhs(1, i1, i2, 5, q) = -1._wp + i1 + momrhs(2, i1, i2, 5, q) = i2 + momrhs(3, i1, i2, 5, q) = 0._wp + + momrhs(1, i1, i2, 6, q) = -1._wp + i1 + momrhs(2, i1, i2, 6, q) = 1._wp + i2 + momrhs(3, i1, i2, 6, q) = 0._wp + + momrhs(1, i1, i2, 7, q) = -1._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 7, q) = -1._wp + i2 + momrhs(3, i1, i2, 7, q) = 3._wp*gam + + momrhs(1, i1, i2, 8, q) = -1._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 8, q) = i2 + momrhs(3, i1, i2, 8, q) = 3._wp*gam + + momrhs(1, i1, i2, 9, q) = -1._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 9, q) = 1._wp + i2 + momrhs(3, i1, i2, 9, q) = 3._wp*gam + + momrhs(1, i1, i2, 10, q) = -1._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 10, q) = i2 + momrhs(3, i1, i2, 10, q) = 3._wp*gam + + momrhs(1, i1, i2, 11, q) = -1._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 11, q) = 1._wp + i2 + momrhs(3, i1, i2, 11, q) = 3._wp*gam + + momrhs(1, i1, i2, 12, q) = -1._wp + i1 + momrhs(2, i1, i2, 12, q) = 1._wp + i2 + momrhs(3, i1, i2, 12, q) = 0._wp + + momrhs(1, i1, i2, 13, q) = -1._wp + i1 + momrhs(2, i1, i2, 13, q) = -1._wp + i2 + momrhs(3, i1, i2, 13, q) = 0._wp + + momrhs(1, i1, i2, 14, q) = -1._wp + i1 + momrhs(2, i1, i2, 14, q) = i2 + momrhs(3, i1, i2, 14, q) = 0._wp + + momrhs(1, i1, i2, 15, q) = -1._wp + i1 + momrhs(2, i1, i2, 15, q) = 1._wp + i2 + momrhs(3, i1, i2, 15, q) = 0._wp + + momrhs(1, i1, i2, 16, q) = -2._wp + i1 + momrhs(2, i1, i2, 16, q) = i2 + momrhs(3, i1, i2, 16, q) = 0._wp + + momrhs(1, i1, i2, 17, q) = -2._wp + i1 + momrhs(2, i1, i2, 17, q) = -1._wp + i2 + momrhs(3, i1, i2, 17, q) = 0._wp + + momrhs(1, i1, i2, 18, q) = -2._wp + i1 + momrhs(2, i1, i2, 18, q) = 1._wp + i2 + momrhs(3, i1, i2, 18, q) = 0._wp + + momrhs(1, i1, i2, 19, q) = -2._wp + i1 + momrhs(2, i1, i2, 19, q) = 2._wp + i2 + momrhs(3, i1, i2, 19, q) = 0._wp + + momrhs(1, i1, i2, 20, q) = -2._wp + i1 + momrhs(2, i1, i2, 20, q) = -1._wp + i2 + momrhs(3, i1, i2, 20, q) = 0._wp + + momrhs(1, i1, i2, 21, q) = -2._wp + i1 + momrhs(2, i1, i2, 21, q) = i2 + momrhs(3, i1, i2, 21, q) = 0._wp + + momrhs(1, i1, i2, 22, q) = -2._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 22, q) = -1._wp + i2 + momrhs(3, i1, i2, 22, q) = 3._wp*gam + + momrhs(1, i1, i2, 23, q) = -2._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 23, q) = i2 + momrhs(3, i1, i2, 23, q) = 3._wp*gam + + momrhs(1, i1, i2, 24, q) = -3._wp + i1 + momrhs(2, i1, i2, 24, q) = i2 + momrhs(3, i1, i2, 24, q) = 0._wp + + momrhs(1, i1, i2, 25, q) = -3._wp + i1 + momrhs(2, i1, i2, 25, q) = -1._wp + i2 + momrhs(3, i1, i2, 25, q) = 0._wp + + momrhs(1, i1, i2, 26, q) = -2._wp + i1 - 3._wp*gam + momrhs(2, i1, i2, 26, q) = i2 + momrhs(3, i1, i2, 26, q) = 3._wp*gam end if - end do; end do + end if + end do; end do end do end if @@ -409,22 +400,20 @@ contains end do end do $:GPU_UPDATE(device='[bubmoms]') - end subroutine s_initialize_qbmm_module - !> @brief Computes the QBMM right-hand side source terms for bubble moment transport equations. subroutine s_compute_qbmm_rhs(idir, q_cons_vf, q_prim_vf, rhs_vf, flux_n_vf, pb, rhs_pb) - - integer, intent(in) :: idir - type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf, q_prim_vf - type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - type(scalar_field), dimension(sys_size), intent(in) :: flux_n_vf + integer, intent(in) :: idir + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf, q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf + type(scalar_field), dimension(sys_size), intent(in) :: flux_n_vf real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & + & intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. - integer :: i, j, k, l, q + integer :: i, j, k, l, q real(wp) :: nb_q, nb_dot, R, R2, nR, nR2, nR_dot, nR2_dot, var, AX - logical :: is_axisym + logical :: is_axisym select case (idir) case (1) @@ -436,7 +425,7 @@ contains end select if (.not. polytropic) then - $:GPU_PARALLEL_LOOP(collapse=5,private='[i,j,k,l,q,nb_q,nR,nR2,R,R2,nb_dot,nR_dot,nR2_dot,var,AX]') + $:GPU_PARALLEL_LOOP(collapse=5,private='[i, j, k, l, q, nb_q, nR, nR2, R, R2, nb_dot, nR_dot, nR2_dot, var, AX]') do i = 1, nb do q = 1, nnode do l = 0, p @@ -456,80 +445,109 @@ contains select case (idir) case (1) - nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j - 1, k, l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) - nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j - 1, k, l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) - nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j - 1, k, l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dx(j)*AX*nb_q**2)* & - (nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j - 1, k, & + & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j - 1, k, & + & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j - 1, k, & + & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) case (2) - nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k - 1, l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) - nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k - 1, l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) - nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k - 1, l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dy(k)*AX*nb_q**2)* & - (nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k - 1, & + & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k - 1, & + & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k - 1, & + & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) case (3) if (is_axisym) then - nb_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l)) - nR_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)) - nR2_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2)* & - (nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + nb_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, & + & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l)) + nR_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, & + & k, l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)) + nR2_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, & + & k, l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, & + & q, i)) else - nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) - nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) - nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dz(l)*AX*nb_q**2)* & - (nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, & + & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, & + & l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, & + & l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) end if end select if (q <= 2) then select case (idir) case (1) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)* & - (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)* & - (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (2) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)* & - (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)* & - (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (3) if (is_axisym) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)* & - (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)* & - (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & + & - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)* & - (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)* & - (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end select else select case (idir) case (1) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)* & - (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)* & - (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (2) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)* & - (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)* & - (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (3) if (is_axisym) then - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)* & - (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)* & - (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & + & - nR2*nb_dot)*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)* & - (nR2_dot*nb_q - nR2*nb_dot)*(pb(j, k, l, q, i)) - rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)* & - (-2._wp*(nR/nb_q)*(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) + rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end select end if @@ -543,7 +561,7 @@ contains ! The following block is not repeated and is left as is if (idir == 1) then - $:GPU_PARALLEL_LOOP(private='[i,l,q]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, l, q]', collapse=3) do l = 0, p do q = 0, n do i = 0, m @@ -564,13 +582,10 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_compute_qbmm_rhs - !> @brief Builds the coefficient array for the non-polytropic bubble model. subroutine s_coeff_nonpoly(pres, rho, c, coeffs) - $:GPU_ROUTINE(function_name='s_coeff_nonpoly',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_coeff_nonpoly',parallelism='[seq]', cray_inline=True) real(wp), intent(in) :: pres, rho, c #:if USING_AMD @@ -581,75 +596,72 @@ contains integer :: i1, i2 - coeffs(:, :, :) = 0._wp + coeffs(:,:,:) = 0._wp do i2 = 0, 2; do i1 = 0, 2 - if ((i1 + i2) <= 2) then - if (bubble_model == 3) then - #:if not MFC_CASE_OPTIMIZATION or nterms > 1 - ! RPE - coeffs(1, i1, i2) = -1._wp*i2*pres/rho - coeffs(2, i1, i2) = -3._wp*i2/2._wp - coeffs(3, i1, i2) = i2/rho - coeffs(4, i1, i2) = i1 - if (.not. f_is_default(Re_inv)) coeffs(5, i1, i2) = -4._wp*i2*Re_inv/rho - if (.not. f_is_default(Web)) coeffs(6, i1, i2) = -2._wp*i2/Web/rho - coeffs(7, i1, i2) = 0._wp - #:endif - else if (bubble_model == 2) then - ! KM with approximation of 1/(1-V/C) = 1+V/C - #:if not MFC_CASE_OPTIMIZATION or nterms > 7 - coeffs(1, i1, i2) = -3._wp*i2/2._wp - coeffs(2, i1, i2) = -i2/c - coeffs(3, i1, i2) = i2/(2._wp*c*c) - coeffs(4, i1, i2) = -i2*pres/rho - coeffs(5, i1, i2) = -2._wp*i2*pres/(c*rho) - coeffs(6, i1, i2) = -i2*pres/(c*c*rho) - coeffs(7, i1, i2) = i2/rho - coeffs(8, i1, i2) = 2._wp*i2/(c*rho) - coeffs(9, i1, i2) = i2/(c*c*rho) - coeffs(10, i1, i2) = -3._wp*i2*gam/(c*rho) - coeffs(11, i1, i2) = -3._wp*i2*gam/(c*c*rho) - coeffs(12, i1, i2) = i1 - coeffs(13, i1, i2) = 0._wp - coeffs(14, i1, i2) = 0._wp - coeffs(15, i1, i2) = 0._wp - if (.not. f_is_default(Re_inv)) coeffs(16, i1, i2) = -i2*4._wp*Re_inv/rho - if (.not. f_is_default(Web)) coeffs(17, i1, i2) = -i2*2._wp/Web/rho - if (.not. f_is_default(Re_inv)) then - coeffs(18, i1, i2) = i2*6._wp*Re_inv/(rho*c) - coeffs(19, i1, i2) = -i2*2._wp*Re_inv/(rho*c*c) - coeffs(20, i1, i2) = i2*4._wp*pres*Re_inv/(rho*rho*c) - coeffs(21, i1, i2) = i2*4._wp*pres*Re_inv/(rho*rho*c*c) - coeffs(22, i1, i2) = -i2*4._wp*Re_inv/(rho*rho*c) - coeffs(23, i1, i2) = -i2*4._wp*Re_inv/(rho*rho*c*c) - coeffs(24, i1, i2) = i2*16._wp*Re_inv*Re_inv/(rho*rho*c) - if (.not. f_is_default(Web)) then - coeffs(25, i1, i2) = i2*8._wp*Re_inv/Web/(rho*rho*c) - end if - coeffs(26, i1, i2) = -12._wp*i2*gam*Re_inv/(rho*rho*c*c) - end if - coeffs(27, i1, i2) = 3._wp*i2*gam*R_v*Tw/(c*rho) - coeffs(28, i1, i2) = 3._wp*i2*gam*R_v*Tw/(c*c*rho) - if (.not. f_is_default(Re_inv)) then - coeffs(29, i1, i2) = 12._wp*i2*gam*R_v*Tw*Re_inv/(rho*rho*c*c) - end if - coeffs(30, i1, i2) = 3._wp*i2*gam/(c*rho) - coeffs(31, i1, i2) = 3._wp*i2*gam/(c*c*rho) - if (.not. f_is_default(Re_inv)) then - coeffs(32, i1, i2) = 12._wp*i2*gam*Re_inv/(rho*rho*c*c) + if ((i1 + i2) <= 2) then + if (bubble_model == 3) then + #:if not MFC_CASE_OPTIMIZATION or nterms > 1 + ! RPE + coeffs(1, i1, i2) = -1._wp*i2*pres/rho + coeffs(2, i1, i2) = -3._wp*i2/2._wp + coeffs(3, i1, i2) = i2/rho + coeffs(4, i1, i2) = i1 + if (.not. f_is_default(Re_inv)) coeffs(5, i1, i2) = -4._wp*i2*Re_inv/rho + if (.not. f_is_default(Web)) coeffs(6, i1, i2) = -2._wp*i2/Web/rho + coeffs(7, i1, i2) = 0._wp + #:endif + else if (bubble_model == 2) then + ! KM with approximation of 1/(1-V/C) = 1+V/C + #:if not MFC_CASE_OPTIMIZATION or nterms > 7 + coeffs(1, i1, i2) = -3._wp*i2/2._wp + coeffs(2, i1, i2) = -i2/c + coeffs(3, i1, i2) = i2/(2._wp*c*c) + coeffs(4, i1, i2) = -i2*pres/rho + coeffs(5, i1, i2) = -2._wp*i2*pres/(c*rho) + coeffs(6, i1, i2) = -i2*pres/(c*c*rho) + coeffs(7, i1, i2) = i2/rho + coeffs(8, i1, i2) = 2._wp*i2/(c*rho) + coeffs(9, i1, i2) = i2/(c*c*rho) + coeffs(10, i1, i2) = -3._wp*i2*gam/(c*rho) + coeffs(11, i1, i2) = -3._wp*i2*gam/(c*c*rho) + coeffs(12, i1, i2) = i1 + coeffs(13, i1, i2) = 0._wp + coeffs(14, i1, i2) = 0._wp + coeffs(15, i1, i2) = 0._wp + if (.not. f_is_default(Re_inv)) coeffs(16, i1, i2) = -i2*4._wp*Re_inv/rho + if (.not. f_is_default(Web)) coeffs(17, i1, i2) = -i2*2._wp/Web/rho + if (.not. f_is_default(Re_inv)) then + coeffs(18, i1, i2) = i2*6._wp*Re_inv/(rho*c) + coeffs(19, i1, i2) = -i2*2._wp*Re_inv/(rho*c*c) + coeffs(20, i1, i2) = i2*4._wp*pres*Re_inv/(rho*rho*c) + coeffs(21, i1, i2) = i2*4._wp*pres*Re_inv/(rho*rho*c*c) + coeffs(22, i1, i2) = -i2*4._wp*Re_inv/(rho*rho*c) + coeffs(23, i1, i2) = -i2*4._wp*Re_inv/(rho*rho*c*c) + coeffs(24, i1, i2) = i2*16._wp*Re_inv*Re_inv/(rho*rho*c) + if (.not. f_is_default(Web)) then + coeffs(25, i1, i2) = i2*8._wp*Re_inv/Web/(rho*rho*c) end if - #:endif - end if + coeffs(26, i1, i2) = -12._wp*i2*gam*Re_inv/(rho*rho*c*c) + end if + coeffs(27, i1, i2) = 3._wp*i2*gam*R_v*Tw/(c*rho) + coeffs(28, i1, i2) = 3._wp*i2*gam*R_v*Tw/(c*c*rho) + if (.not. f_is_default(Re_inv)) then + coeffs(29, i1, i2) = 12._wp*i2*gam*R_v*Tw*Re_inv/(rho*rho*c*c) + end if + coeffs(30, i1, i2) = 3._wp*i2*gam/(c*rho) + coeffs(31, i1, i2) = 3._wp*i2*gam/(c*c*rho) + if (.not. f_is_default(Re_inv)) then + coeffs(32, i1, i2) = 12._wp*i2*gam*Re_inv/(rho*rho*c*c) + end if + #:endif end if - end do; end do - + end if + end do; end do end subroutine s_coeff_nonpoly - !> @brief Builds the coefficient array for the polytropic bubble model. subroutine s_coeff(pres, rho, c, coeffs) - $:GPU_ROUTINE(function_name='s_coeff',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_coeff',parallelism='[seq]', cray_inline=True) real(wp), intent(in) :: pres, rho, c #:if USING_AMD @@ -660,77 +672,74 @@ contains integer :: i1, i2 - coeffs(:, :, :) = 0._wp + coeffs(:,:,:) = 0._wp do i2 = 0, 2; do i1 = 0, 2 - if ((i1 + i2) <= 2) then - if (bubble_model == 3) then - ! RPE - #:if not MFC_CASE_OPTIMIZATION or nterms > 1 - coeffs(1, i1, i2) = -1._wp*i2*pres/rho - coeffs(2, i1, i2) = -3._wp*i2/2._wp - coeffs(3, i1, i2) = i2/rho - coeffs(4, i1, i2) = i1 - if (.not. f_is_default(Re_inv)) coeffs(5, i1, i2) = -4._wp*i2*Re_inv/rho - if (.not. f_is_default(Web)) coeffs(6, i1, i2) = -2._wp*i2/Web/rho - coeffs(7, i1, i2) = i2*pv/rho - #:endif - else if (bubble_model == 2) then - ! KM with approximation of 1/(1-V/C) = 1+V/C - #:if not MFC_CASE_OPTIMIZATION or nterms > 7 - coeffs(1, i1, i2) = -3._wp*i2/2._wp - coeffs(2, i1, i2) = -i2/c - coeffs(3, i1, i2) = i2/(2._wp*c*c) - coeffs(4, i1, i2) = -i2*pres/rho - coeffs(5, i1, i2) = -2._wp*i2*pres/(c*rho) - coeffs(6, i1, i2) = -i2*pres/(c*c*rho) - coeffs(7, i1, i2) = i2/rho - coeffs(8, i1, i2) = 2._wp*i2/(c*rho) - coeffs(9, i1, i2) = i2/(c*c*rho) - coeffs(10, i1, i2) = -3._wp*i2*gam/(c*rho) - coeffs(11, i1, i2) = -3._wp*i2*gam/(c*c*rho) - coeffs(12, i1, i2) = i1 - coeffs(13, i1, i2) = i2*(pv)/rho - coeffs(14, i1, i2) = 2._wp*i2*(pv)/(c*rho) - coeffs(15, i1, i2) = i2*(pv)/(c*c*rho) - if (.not. f_is_default(Re_inv)) coeffs(16, i1, i2) = -i2*4._wp*Re_inv/rho - if (.not. f_is_default(Web)) coeffs(17, i1, i2) = -i2*2._wp/Web/rho - if (.not. f_is_default(Re_inv)) then - coeffs(18, i1, i2) = i2*6._wp*Re_inv/(rho*c) - coeffs(19, i1, i2) = -i2*2._wp*Re_inv/(rho*c*c) - coeffs(20, i1, i2) = i2*4._wp*pres*Re_inv/(rho*rho*c) - coeffs(21, i1, i2) = i2*4._wp*pres*Re_inv/(rho*rho*c*c) - coeffs(22, i1, i2) = -i2*4._wp*Re_inv/(rho*rho*c) - coeffs(23, i1, i2) = -i2*4._wp*Re_inv/(rho*rho*c*c) - coeffs(24, i1, i2) = i2*16._wp*Re_inv*Re_inv/(rho*rho*c) - if (.not. f_is_default(Web)) then - coeffs(25, i1, i2) = i2*8._wp*Re_inv/Web/(rho*rho*c) - end if - coeffs(26, i1, i2) = -12._wp*i2*gam*Re_inv/(rho*rho*c*c) + if ((i1 + i2) <= 2) then + if (bubble_model == 3) then + ! RPE + #:if not MFC_CASE_OPTIMIZATION or nterms > 1 + coeffs(1, i1, i2) = -1._wp*i2*pres/rho + coeffs(2, i1, i2) = -3._wp*i2/2._wp + coeffs(3, i1, i2) = i2/rho + coeffs(4, i1, i2) = i1 + if (.not. f_is_default(Re_inv)) coeffs(5, i1, i2) = -4._wp*i2*Re_inv/rho + if (.not. f_is_default(Web)) coeffs(6, i1, i2) = -2._wp*i2/Web/rho + coeffs(7, i1, i2) = i2*pv/rho + #:endif + else if (bubble_model == 2) then + ! KM with approximation of 1/(1-V/C) = 1+V/C + #:if not MFC_CASE_OPTIMIZATION or nterms > 7 + coeffs(1, i1, i2) = -3._wp*i2/2._wp + coeffs(2, i1, i2) = -i2/c + coeffs(3, i1, i2) = i2/(2._wp*c*c) + coeffs(4, i1, i2) = -i2*pres/rho + coeffs(5, i1, i2) = -2._wp*i2*pres/(c*rho) + coeffs(6, i1, i2) = -i2*pres/(c*c*rho) + coeffs(7, i1, i2) = i2/rho + coeffs(8, i1, i2) = 2._wp*i2/(c*rho) + coeffs(9, i1, i2) = i2/(c*c*rho) + coeffs(10, i1, i2) = -3._wp*i2*gam/(c*rho) + coeffs(11, i1, i2) = -3._wp*i2*gam/(c*c*rho) + coeffs(12, i1, i2) = i1 + coeffs(13, i1, i2) = i2*(pv)/rho + coeffs(14, i1, i2) = 2._wp*i2*(pv)/(c*rho) + coeffs(15, i1, i2) = i2*(pv)/(c*c*rho) + if (.not. f_is_default(Re_inv)) coeffs(16, i1, i2) = -i2*4._wp*Re_inv/rho + if (.not. f_is_default(Web)) coeffs(17, i1, i2) = -i2*2._wp/Web/rho + if (.not. f_is_default(Re_inv)) then + coeffs(18, i1, i2) = i2*6._wp*Re_inv/(rho*c) + coeffs(19, i1, i2) = -i2*2._wp*Re_inv/(rho*c*c) + coeffs(20, i1, i2) = i2*4._wp*pres*Re_inv/(rho*rho*c) + coeffs(21, i1, i2) = i2*4._wp*pres*Re_inv/(rho*rho*c*c) + coeffs(22, i1, i2) = -i2*4._wp*Re_inv/(rho*rho*c) + coeffs(23, i1, i2) = -i2*4._wp*Re_inv/(rho*rho*c*c) + coeffs(24, i1, i2) = i2*16._wp*Re_inv*Re_inv/(rho*rho*c) + if (.not. f_is_default(Web)) then + coeffs(25, i1, i2) = i2*8._wp*Re_inv/Web/(rho*rho*c) end if - #:endif - end if + coeffs(26, i1, i2) = -12._wp*i2*gam*Re_inv/(rho*rho*c*c) + end if + #:endif end if - end do; end do - + end if + end do; end do end subroutine s_coeff - !> @brief Performs moment inversion to recover quadrature weights and abscissas and evaluates bubble source terms. subroutine s_mom_inv(q_cons_vf, q_prim_vf, momsp, moms3d, pb, rhs_pb, mv, rhs_mv, ix, iy, iz) - - type(scalar_field), dimension(:), intent(inout) :: q_cons_vf, q_prim_vf - type(scalar_field), dimension(:), intent(inout) :: momsp - type(scalar_field), dimension(0:, 0:, :), intent(inout) :: moms3d + type(scalar_field), dimension(:), intent(inout) :: q_cons_vf, q_prim_vf + type(scalar_field), dimension(:), intent(inout) :: momsp + type(scalar_field), dimension(0:, 0:,:), intent(inout) :: moms3d real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_pb + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_pb real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: mv - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv - type(int_bounds_info), intent(in) :: ix, iy, iz + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv + type(int_bounds_info), intent(in) :: ix, iy, iz #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(6) :: moms, msum + real(wp), dimension(6) :: moms, msum real(wp), dimension(4, 3) :: wght, abscX, abscY, wght_pb, wght_mv, wght_ht, ht #:else - real(wp), dimension(nmom) :: moms, msum + real(wp), dimension(nmom) :: moms, msum real(wp), dimension(nnode, nb) :: wght, abscX, abscY, wght_pb, wght_mv, wght_ht, ht #:endif #:if USING_AMD @@ -740,16 +749,16 @@ contains #:endif real(wp) :: pres, rho, nbub, c, alf, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, grad_T real(wp) :: n_tait, B_tait - integer :: id1, id2, id3, i1, i2, j, q, r + integer :: id1, id2, id3, i1, i2, j, q, r is1_qbmm = ix; is2_qbmm = iy; is3_qbmm = iz - $:GPU_UPDATE(device='[is1_qbmm,is2_qbmm,is3_qbmm]') + $:GPU_UPDATE(device='[is1_qbmm, is2_qbmm, is3_qbmm]') - $:GPU_PARALLEL_LOOP(collapse=3, private='[id1,id2,id3,moms, msum, wght, abscX, abscY, wght_pb, wght_mv, wght_ht, coeff, ht, r, q, n_tait, B_tait, pres, rho, nbub, c, alf, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, grad_T, i1, i2, j]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[id1, id2, id3, moms, msum, wght, abscX, abscY, wght_pb, wght_mv, wght_ht, coeff, & + & ht, r, q, n_tait, B_tait, pres, rho, nbub, c, alf, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, grad_T, i1, i2, j]') do id3 = is3_qbmm%beg, is3_qbmm%end do id2 = is2_qbmm%beg, is2_qbmm%end do id1 = is1_qbmm%beg, is1_qbmm%end - alf = q_prim_vf(alf_idx)%sf(id1, id2, id3) pres = q_prim_vf(E_idx)%sf(id1, id2, id3) rho = q_prim_vf(contxb)%sf(id1, id2, id3) @@ -785,11 +794,16 @@ contains do j = 1, nnode chi_vw = 1._wp/(1._wp + R_v/R_g*(pb(id1, id2, id3, j, q)/pv - 1._wp)) x_vw = M_g*chi_vw/(M_v + (M_g - M_v)*chi_vw) - k_mw = x_vw*k_v(q)/(x_vw + (1._wp - x_vw)*phi_vg) + (1._wp - x_vw)*k_g(q)/(x_vw*phi_gv + 1._wp - x_vw) + k_mw = x_vw*k_v(q)/(x_vw + (1._wp - x_vw)*phi_vg) + (1._wp - x_vw)*k_g(q)/(x_vw*phi_gv & + & + 1._wp - x_vw) rho_mw = pv/(chi_vw*R_v*Tw) - rhs_mv(id1, id2, id3, j, q) = -Re_trans_c(q)*((mv(id1, id2, id3, j, q)/(mv(id1, id2, id3, j, q) + mass_g0(q))) - chi_vw) - rhs_mv(id1, id2, id3, j, q) = rho_mw*rhs_mv(id1, id2, id3, j, q)/Pe_c/(1._wp - chi_vw)/abscX(j, q) - grad_T = -Re_trans_T(q)*((pb(id1, id2, id3, j, q)/pb0(q))*(abscX(j, q)/R0(q))**3*(mass_g0(q) + mass_v0(q))/(mass_g0(q) + mv(id1, id2, id3, j, q)) - 1._wp) + rhs_mv(id1, id2, id3, j, q) = -Re_trans_c(q)*((mv(id1, id2, id3, j, q)/(mv(id1, id2, id3, j, & + & q) + mass_g0(q))) - chi_vw) + rhs_mv(id1, id2, id3, j, q) = rho_mw*rhs_mv(id1, id2, id3, j, & + & q)/Pe_c/(1._wp - chi_vw)/abscX(j, q) + grad_T = -Re_trans_T(q)*((pb(id1, id2, id3, j, q)/pb0(q))*(abscX(j, & + & q)/R0(q))**3*(mass_g0(q) + mass_v0(q))/(mass_g0(q) + mv(id1, id2, id3, & + & j, q)) - 1._wp) ht(j, q) = pb0(q)*k_mw*grad_T/Pe_T(q)/abscX(j, q) wght_pb(j, q) = wght(j, q)*(pb(id1, id2, id3, j, q)) wght_mv(j, q) = wght(j, q)*(rhs_mv(id1, id2, id3, j, q)) @@ -810,19 +824,32 @@ contains select case (bubble_model) case (3) if (j == 3) then - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, j, q)) + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, & + & q), momrhs(:, i1, i2, j, q)) else - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), momrhs(:, i1, i2, j, q)) + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), & + & momrhs(:, i1, i2, j, q)) end if case (2) - if ((j >= 7 .and. j <= 9) .or. (j >= 22 .and. j <= 23) .or. (j >= 10 .and. j <= 11) .or. (j == 26)) then - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, j, q)) + if ((j >= 7 .and. j <= 9) .or. (j >= 22 .and. j <= 23) & + & .or. (j >= 10 .and. j <= 11) .or. (j == 26)) then + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, & + & q), momrhs(:, i1, i2, j, q)) else if ((j >= 27 .and. j <= 29) .and. (.not. polytropic)) then - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q))*f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, q), momrhs(:, i1, i2, j, q)) + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, & + & q), momrhs(:, i1, i2, j, q)) else if ((j >= 30 .and. j <= 32) .and. (.not. polytropic)) then - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q))*f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, q), momrhs(:, i1, i2, j, q)) + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, & + & q), momrhs(:, i1, i2, j, q)) else - momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), momrhs(:, i1, i2, j, q)) + momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), & + & momrhs(:, i1, i2, j, q)) end if end select end do @@ -838,14 +865,15 @@ contains $:GPU_LOOP(parallelism='[seq]') do j = 1, nnode drdt = msum(2) - drdt2 = merge(-1._wp, 1._wp, j == 1 .or. j == 2)/(2._wp*sqrt(merge(moms(4) - moms(2)**2._wp, sgm_eps, moms(4) - moms(2)**2._wp > 0._wp))) + drdt2 = merge(-1._wp, 1._wp, j == 1 .or. j == 2)/(2._wp*sqrt(merge(moms(4) - moms(2)**2._wp, & + & sgm_eps, moms(4) - moms(2)**2._wp > 0._wp))) drdt2 = drdt2*(msum(3) - 2._wp*moms(2)*msum(2)) drdt = drdt + drdt2 rhs_pb(id1, id2, id3, j, q) = (-3._wp*gam*drdt/abscX(j, q))*(pb(id1, id2, id3, j, q)) - rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3._wp*gam/abscX(j, q))*rhs_mv(id1, id2, id3, j, q)*R_v*Tw + rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3._wp*gam/abscX(j, & + & q))*rhs_mv(id1, id2, id3, j, q)*R_v*Tw rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3._wp*gam/abscX(j, q))*ht(j, q) rhs_mv(id1, id2, id3, j, q) = rhs_mv(id1, id2, id3, j, q)*(4._wp*pi*abscX(j, q)**2._wp) - end do end if end do @@ -858,9 +886,14 @@ contains momsp(4)%sf(id1, id2, id3) = 1._wp else if (polytropic) then - momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3._wp*(1._wp - gam), 0._wp, 3._wp*gam) + pv*f_quad(abscX, abscY, wght, 3._wp, 0._wp, 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) + momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3._wp*(1._wp - gam), 0._wp, & + & 3._wp*gam) + pv*f_quad(abscX, abscY, wght, 3._wp, 0._wp, & + & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & + & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) else - momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3._wp, 0._wp, 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) + momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3._wp, 0._wp, & + & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & + & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) end if end if else @@ -883,12 +916,10 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - contains !> @brief Selects the polytropic or non-polytropic coefficient routine. subroutine s_coeff_selector(pres, rho, c, coeff, polytropic) - $:GPU_ROUTINE(function_name='s_coeff_selector',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_coeff_selector',parallelism='[seq]', cray_inline=True) real(wp), intent(in) :: pres, rho, c #:if USING_AMD real(wp), dimension(32, 0:2, 0:2), intent(out) :: coeff @@ -902,21 +933,19 @@ contains call s_coeff_nonpoly(pres, rho, c, coeff) end if end subroutine s_coeff_selector - !> @brief Performs conditional hyperbolic QMOM (CHyQMOM) inversion for bivariate moments. subroutine s_chyqmom(momin, wght, abscX, abscY) - $:GPU_ROUTINE(function_name='s_chyqmom',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_chyqmom',parallelism='[seq]', cray_inline=True) - real(wp), dimension(nmom), intent(in) :: momin + real(wp), dimension(nmom), intent(in) :: momin real(wp), dimension(nnode), intent(inout) :: wght, abscX, abscY ! Local variables real(wp), dimension(0:2, 0:2) :: moms - real(wp), dimension(3) :: M1, M3 - real(wp), dimension(2) :: myrho, myrho3, up, up3, Vf - real(wp) :: bu, bv, d20, d11, d_02, c20, c11, c02 - real(wp) :: mu2, vp21, vp22, rho21, rho22 + real(wp), dimension(3) :: M1, M3 + real(wp), dimension(2) :: myrho, myrho3, up, up3, Vf + real(wp) :: bu, bv, d20, d11, d_02, c20, c11, c02 + real(wp) :: mu2, vp21, vp22, rho21, rho22 ! Assign moments to 2D array for clarity moms(0, 0) = momin(1) @@ -959,30 +988,24 @@ contains ! Compute abscissas (vectorized) abscX = bu + [up(1), up(1), up(2), up(2)] abscY = bv + [Vf(1) + vp21, Vf(1) + vp22, Vf(2) + vp21, Vf(2) + vp22] - end subroutine s_chyqmom - !> @brief Performs hyperbolic QMOM (HyQMOM) inversion for univariate moments. subroutine s_hyqmom(frho, fup, fmom) - $:GPU_ROUTINE(function_name='s_hyqmom',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_hyqmom',parallelism='[seq]', cray_inline=True) real(wp), dimension(2), intent(inout) :: frho, fup - real(wp), dimension(3), intent(in) :: fmom - - real(wp) :: bu, d2, c2 + real(wp), dimension(3), intent(in) :: fmom + real(wp) :: bu, d2, c2 bu = fmom(2)/fmom(1) d2 = fmom(3)/fmom(1) c2 = d2 - bu**2._wp - frho(1) = fmom(1)/2._wp; - frho(2) = fmom(1)/2._wp; + frho(1) = fmom(1)/2._wp; + frho(2) = fmom(1)/2._wp; c2 = maxval((/c2, sgm_eps/)) fup(1) = bu - sqrt(c2) fup(2) = bu + sqrt(c2) - end subroutine s_hyqmom - !> @brief Evaluates a weighted quadrature sum over all bubble size bins and nodes. function f_quad(abscX, abscY, wght_in, q, r, s) $:GPU_ROUTINE(parallelism='[seq]') @@ -992,9 +1015,8 @@ contains real(wp), dimension(nnode, nb), intent(in) :: abscX, abscY, wght_in #:endif real(wp), intent(in) :: q, r, s - - real(wp) :: f_quad_RV, f_quad - integer :: i, i1 + real(wp) :: f_quad_RV, f_quad + integer :: i, i1 f_quad = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -1006,9 +1028,7 @@ contains end do f_quad = f_quad + weight(i)*(R0(i)**s)*f_quad_RV end do - end function f_quad - !> @brief Evaluates a weighted 2D quadrature sum over quadrature nodes for a single size bin. function f_quad2D(abscX, abscY, wght_in, pow) $:GPU_ROUTINE(parallelism='[seq]') @@ -1018,9 +1038,8 @@ contains real(wp), dimension(nnode), intent(in) :: abscX, abscY, wght_in #:endif real(wp), dimension(3), intent(in) :: pow - - real(wp) :: f_quad2D - integer :: i + real(wp) :: f_quad2D + integer :: i f_quad2D = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -1028,7 +1047,5 @@ contains f_quad2D = f_quad2D + wght_in(i)*(abscX(i)**pow(1))*(abscY(i)**pow(2)) end do end function f_quad2D - end subroutine s_mom_inv - end module m_qbmm diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 6b8288a0b8..2bffac426f 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -5,9 +5,9 @@ #:include 'case.fpp' #:include 'macros.fpp' -!> @brief Assembles the right-hand side of the governing equations using finite-volume flux differencing, Riemann solvers, and physical source terms +!> @brief Assembles the right-hand side of the governing equations using finite-volume flux differencing, Riemann solvers, and +!! physical source terms module m_rhs - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -60,9 +60,7 @@ module m_rhs implicit none - private; public :: s_initialize_rhs_module, & - s_compute_rhs, & - s_finalize_rhs_module + private; public :: s_initialize_rhs_module, s_compute_rhs, s_finalize_rhs_module !! This variable contains the WENO-reconstructed values of the cell-average !! conservative variables, which are located in q_cons_vf, at cell-interior @@ -76,26 +74,23 @@ module m_rhs type(vector_field) :: q_prim_qp !< $:GPU_DECLARE(create='[q_prim_qp]') - !> @name The first-order spatial derivatives of the primitive variables at cell- - !! interior Gaussian quadrature points. These are WENO-reconstructed from - !! their respective cell-average values, obtained through the application - !! of the divergence theorem on the integral-average cell-boundary values - !! of the primitive variables, located in qK_prim_n, where K = L or R. + !> @name The first-order spatial derivatives of the primitive variables at cell- interior Gaussian quadrature points. These are + !! WENO-reconstructed from their respective cell-average values, obtained through the application of the divergence theorem on + !! the integral-average cell-boundary values of the primitive variables, located in qK_prim_n, where K = L or R. !> @{ type(vector_field), allocatable, dimension(:) :: dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp - $:GPU_DECLARE(create='[dq_prim_dx_qp,dq_prim_dy_qp,dq_prim_dz_qp]') + $:GPU_DECLARE(create='[dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp]') !> @} - !> @name The left and right WENO-reconstructed cell-boundary values of the cell- - !! average first-order spatial derivatives of the primitive variables. The - !! cell-average of the first-order spatial derivatives may be found in the - !! variables dq_prim_ds_qp, where s = x, y or z. + !> @name The left and right WENO-reconstructed cell-boundary values of the cell- average first-order spatial derivatives of the + !! primitive variables. The cell-average of the first-order spatial derivatives may be found in the variables dq_prim_ds_qp, + !! where s = x, y or z. !> @{ type(vector_field), allocatable, dimension(:) :: dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n type(vector_field), allocatable, dimension(:) :: dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n #if defined(MFC_OpenACC) - $:GPU_DECLARE(create='[dqL_prim_dx_n,dqL_prim_dy_n,dqL_prim_dz_n]') - $:GPU_DECLARE(create='[dqR_prim_dx_n,dqR_prim_dy_n,dqR_prim_dz_n]') + $:GPU_DECLARE(create='[dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n]') + $:GPU_DECLARE(create='[dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n]') #endif !> @} @@ -109,33 +104,32 @@ module m_rhs $:GPU_DECLARE(create='[gm_alpha_qp]') - !> @name The left and right WENO-reconstructed cell-boundary values of the cell- - !! average gradient magnitude of volume fractions, located in gm_alpha_qp. + !> @name The left and right WENO-reconstructed cell-boundary values of the cell- average gradient magnitude of volume fractions, + !! located in gm_alpha_qp. !> @{ type(vector_field), allocatable, dimension(:) :: gm_alphaL_n type(vector_field), allocatable, dimension(:) :: gm_alphaR_n #if defined(MFC_OpenACC) - $:GPU_DECLARE(create='[gm_alphaL_n,gm_alphaR_n]') + $:GPU_DECLARE(create='[gm_alphaL_n, gm_alphaR_n]') #endif !> @} - !> @name The cell-boundary values of the fluxes (src - source, gsrc - geometrical - !! source). These are computed by applying the chosen Riemann problem solver - !! .on the left and right cell-boundary values of the primitive variables + !> @name The cell-boundary values of the fluxes (src - source, gsrc - geometrical source). These are computed by applying the + !! chosen Riemann problem solver .on the left and right cell-boundary values of the primitive variables !> @{ type(vector_field), allocatable, dimension(:) :: flux_n type(vector_field), allocatable, dimension(:) :: flux_src_n type(vector_field), allocatable, dimension(:) :: flux_gsrc_n #if defined(MFC_OpenACC) - $:GPU_DECLARE(create='[flux_n,flux_src_n,flux_gsrc_n]') + $:GPU_DECLARE(create='[flux_n, flux_src_n, flux_gsrc_n]') #endif !> @} type(vector_field), allocatable, dimension(:) :: qL_prim, qR_prim #if defined(MFC_OpenACC) - $:GPU_DECLARE(create='[qL_prim,qR_prim]') + $:GPU_DECLARE(create='[qL_prim, qR_prim]') #endif type(int_bounds_info) :: iv !< Vector field indical bounds @@ -144,11 +138,11 @@ module m_rhs !> @name Indical bounds in the x-, y- and z-directions !> @{ type(int_bounds_info) :: irx, iry, irz - $:GPU_DECLARE(create='[irx,iry,irz]') + $:GPU_DECLARE(create='[irx, iry, irz]') type(int_bounds_info) :: is1, is2, is3 !> @} - $:GPU_DECLARE(create='[is1,is2,is3]') + $:GPU_DECLARE(create='[is1, is2, is3]') !> @name Saved fluxes for testing !> @{ @@ -156,23 +150,20 @@ module m_rhs !> @} $:GPU_DECLARE(create='[alf_sum]') - real(wp), allocatable, dimension(:, :, :) :: blkmod1, blkmod2, alpha1, alpha2, Kterm - real(wp), allocatable, dimension(:, :, :, :) :: qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf - real(wp), allocatable, dimension(:, :, :, :) :: dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf - $:GPU_DECLARE(create='[blkmod1,blkmod2,alpha1,alpha2,Kterm]') - $:GPU_DECLARE(create='[qL_rsx_vf,qL_rsy_vf,qL_rsz_vf,qR_rsx_vf,qR_rsy_vf,qR_rsz_vf]') - $:GPU_DECLARE(create='[dqL_rsx_vf,dqL_rsy_vf,dqL_rsz_vf,dqR_rsx_vf,dqR_rsy_vf,dqR_rsz_vf]') + real(wp), allocatable, dimension(:,:,:) :: blkmod1, blkmod2, alpha1, alpha2, Kterm + real(wp), allocatable, dimension(:,:,:,:) :: qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf + real(wp), allocatable, dimension(:,:,:,:) :: dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf + $:GPU_DECLARE(create='[blkmod1, blkmod2, alpha1, alpha2, Kterm]') + $:GPU_DECLARE(create='[qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf]') + $:GPU_DECLARE(create='[dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf]') - real(wp), allocatable, dimension(:, :, :) :: nbub !< Bubble number density + real(wp), allocatable, dimension(:,:,:) :: nbub !< Bubble number density $:GPU_DECLARE(create='[nbub]') - contains - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_rhs_module - integer :: i, j, k, l, id !< Generic loop iterators $:GPU_ENTER_DATA(copyin='[idwbuff]') @@ -188,7 +179,6 @@ contains do l = mom_idx%beg, E_idx @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do - end if if (surface_tension) then @@ -202,7 +192,6 @@ contains do l = adv_idx%end + 1, sys_size @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do - end if if (.not. igr) then @@ -227,15 +216,13 @@ contains end if if (surface_tension) then - q_prim_qp%vf(c_idx)%sf => & - q_cons_qp%vf(c_idx)%sf + q_prim_qp%vf(c_idx)%sf => q_cons_qp%vf(c_idx)%sf $:GPU_ENTER_DATA(copyin='[q_prim_qp%vf(c_idx)%sf]') $:GPU_ENTER_DATA(attach='[q_prim_qp%vf(c_idx)%sf]') end if if (hyper_cleaning) then - q_prim_qp%vf(psi_idx)%sf => & - q_cons_qp%vf(psi_idx)%sf + q_prim_qp%vf(psi_idx)%sf => q_cons_qp%vf(psi_idx)%sf $:GPU_ENTER_DATA(copyin='[q_prim_qp%vf(psi_idx)%sf]') $:GPU_ENTER_DATA(attach='[q_prim_qp%vf(psi_idx)%sf]') end if @@ -247,67 +234,41 @@ contains @:ALLOCATE(flux_gsrc_n(1:num_dims)) do i = 1, num_dims - @:ALLOCATE(flux_n(i)%vf(1:sys_size)) @:ALLOCATE(flux_src_n(i)%vf(1:sys_size)) @:ALLOCATE(flux_gsrc_n(i)%vf(1:sys_size)) if (i == 1) then do l = 1, sys_size - @:ALLOCATE(flux_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do if (viscous .or. surface_tension) then do l = mom_idx%beg, E_idx - @:ALLOCATE(flux_src_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do end if - @:ALLOCATE(flux_src_n(i)%vf(adv_idx%beg)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(adv_idx%beg)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) if (riemann_solver == 1 .or. riemann_solver == 4) then do l = adv_idx%beg + 1, adv_idx%end - @:ALLOCATE(flux_src_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do end if if (chemistry) then do l = chemxb, chemxe - @:ALLOCATE(flux_src_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do if (chem_params%diffusion .and. .not. viscous) then - @:ALLOCATE(flux_src_n(i)%vf(E_idx)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(E_idx)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end if end if - else do l = 1, sys_size - @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf( & - idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -329,13 +290,11 @@ contains $:GPU_ENTER_DATA(attach='[flux_src_n(i)%vf(l)%sf]') end do end if - end do ! END: Allocation/Association of flux_n, flux_src_n, and flux_gsrc_n end if if ((.not. igr) .or. dummy) then - ! Allocation of dq_prim_ds_qp @:ALLOCATE(dq_prim_dx_qp(1:1)) @:ALLOCATE(dq_prim_dy_qp(1:1)) @@ -362,35 +321,23 @@ contains @:ACC_SETUP_VFs(qL_prim(i), qR_prim(i)) end do - @:ALLOCATE(qL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - @:ALLOCATE(qR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) if (n > 0) then - - @:ALLOCATE(qL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - @:ALLOCATE(qR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) else - @:ALLOCATE(qL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - @:ALLOCATE(qR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) end if if (p > 0) then - @:ALLOCATE(qL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, 1:sys_size)) - @:ALLOCATE(qR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, 1:sys_size)) + @:ALLOCATE(qL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, 1:sys_size)) + @:ALLOCATE(qR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, 1:sys_size)) else - @:ALLOCATE(qL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - @:ALLOCATE(qR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - + @:ALLOCATE(qL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) end if if (.not. viscous) then @@ -416,17 +363,12 @@ contains end if if (viscous) then - @:ALLOCATE(tau_Re_vf(1:sys_size)) do i = 1, num_dims - @:ALLOCATE(tau_Re_vf(cont_idx%end + i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(tau_Re_vf(cont_idx%end + i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(tau_Re_vf(cont_idx%end + i)) end do - @:ALLOCATE(tau_Re_vf(E_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(tau_Re_vf(E_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(tau_Re_vf(E_idx)) @:ALLOCATE(dq_prim_dx_qp(1)%vf(1:sys_size)) @@ -434,36 +376,24 @@ contains @:ALLOCATE(dq_prim_dz_qp(1)%vf(1:sys_size)) do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dq_prim_dx_qp(1)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dq_prim_dx_qp(1)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dx_qp(1)) if (n > 0) then - do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dq_prim_dy_qp(1)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dq_prim_dy_qp(1)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dy_qp(1)) if (p > 0) then - do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dq_prim_dz_qp(1)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dq_prim_dz_qp(1)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dz_qp(1)) end if - end if do i = 1, num_dims @@ -476,41 +406,22 @@ contains end do do i = 1, num_dims - do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dqL_prim_dx_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(dqR_prim_dx_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqL_prim_dx_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqR_prim_dx_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do if (n > 0) then do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dqL_prim_dy_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(dqR_prim_dy_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqL_prim_dy_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqR_prim_dy_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do end if if (p > 0) then do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dqL_prim_dz_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(dqR_prim_dz_n(i)%vf(l)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqL_prim_dz_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqR_prim_dz_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -519,36 +430,25 @@ contains end do if (weno_Re_flux) then - @:ALLOCATE(dqL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) if (n > 0) then - @:ALLOCATE(dqL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) else - @:ALLOCATE(dqL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) end if if (p > 0) then - @:ALLOCATE(dqL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) else - @:ALLOCATE(dqL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) end if end if ! end allocation for weno_Re_flux - else @:ALLOCATE(dq_prim_dx_qp(1)%vf(1:sys_size)) @:ALLOCATE(dq_prim_dy_qp(1)%vf(1:sys_size)) @@ -568,7 +468,7 @@ contains end do end if ! end allocation of viscous variables - $:GPU_PARALLEL_LOOP(private='[i,j,k,l,id]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l, id]', collapse=4) do id = 1, num_dims do i = 1, sys_size do l = idwbuff(3)%beg, idwbuff(3)%end @@ -581,7 +481,6 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end if ! end allocation for .not. igr if (qbmm) then @@ -590,20 +489,14 @@ contains do i = 0, 2 do j = 0, 2 do k = 1, nb - @:ALLOCATE(mom_3d(i, j, k)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(mom_3d(i, j, k)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(mom_3d(i, j, k)) end do end do end do do i = 1, nmomsp - @:ALLOCATE(mom_sp(i)%sf( & - & idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(mom_sp(i)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(mom_sp(i)) end do end if @@ -628,28 +521,28 @@ contains if (bubbles_euler) then @:ALLOCATE(nbub(0:m, 0:n, 0:p)) end if - end subroutine s_initialize_rhs_module - !> @brief Computes the right-hand side of the semi-discrete governing equations for a single time stage. - impure subroutine s_compute_rhs(q_cons_vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_in, rhs_pb, mv_in, rhs_mv, t_step, time_avg, stage) - - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - type(scalar_field), intent(inout) :: q_T_sf - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf + impure subroutine s_compute_rhs(q_cons_vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_in, rhs_pb, mv_in, rhs_mv, t_step, & + & time_avg, stage) + + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & + & intent(inout) & + & :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: mv_in - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv - integer, intent(in) :: t_step - real(wp), intent(inout) :: time_avg - integer, intent(in) :: stage - - real(wp) :: t_start, t_finish - integer :: id - integer(kind=8) :: i, j, k, l, q !< Generic loop iterators + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv + integer, intent(in) :: t_step + real(wp), intent(inout) :: time_avg + integer, intent(in) :: stage + real(wp) :: t_start, t_finish + integer :: id + integer(kind=8) :: i, j, k, l, q !< Generic loop iterators call nvtxStartRange("COMPUTE-RHS") @@ -657,7 +550,7 @@ contains if (.not. igr .or. dummy) then ! Association/Population of Working Variables - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = 1, sys_size do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end @@ -672,7 +565,7 @@ contains ! Converting Conservative to Primitive Variables if (mpp_lim .and. bubbles_euler) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end @@ -683,8 +576,8 @@ contains end do $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - 1 - q_cons_qp%vf(i)%sf(j, k, l) = q_cons_qp%vf(i)%sf(j, k, l)*(1._wp - q_cons_qp%vf(alf_idx)%sf(j, k, l)) & - /alf_sum%sf(j, k, l) + q_cons_qp%vf(i)%sf(j, k, l) = q_cons_qp%vf(i)%sf(j, k, l)*(1._wp - q_cons_qp%vf(alf_idx)%sf(j, k, & + & l))/alf_sum%sf(j, k, l) end do end do end do @@ -700,11 +593,7 @@ contains end if if (.not. igr .or. dummy) then call nvtxStartRange("RHS-CONVERT") - call s_convert_conservative_to_primitive_variables( & - q_cons_qp%vf, & - q_T_sf, & - q_prim_qp%vf, & - idwint) + call s_convert_conservative_to_primitive_variables(q_cons_qp%vf, q_T_sf, q_prim_qp%vf, idwint) call nvtxEndRange call nvtxStartRange("RHS-COMMUNICATION") @@ -722,19 +611,14 @@ contains if (t_step == t_step_stop) return end if - if (qbmm) call s_mom_inv(q_cons_qp%vf, q_prim_qp%vf, mom_sp, mom_3d, pb_in, rhs_pb, mv_in, rhs_mv, idwbuff(1), idwbuff(2), idwbuff(3)) + if (qbmm) call s_mom_inv(q_cons_qp%vf, q_prim_qp%vf, mom_sp, mom_3d, pb_in, rhs_pb, mv_in, rhs_mv, idwbuff(1), & + & idwbuff(2), idwbuff(3)) if ((viscous .and. .not. igr) .or. dummy) then call nvtxStartRange("RHS-VISCOUS") - call s_get_viscous(qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, & - qL_prim, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, & - qR_prim, & - q_prim_qp, & - dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, & - idwbuff(1), idwbuff(2), idwbuff(3)) + call s_get_viscous(qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, qL_prim, qR_rsx_vf, & + & qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, q_prim_qp, & + & dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, idwbuff(1), idwbuff(2), idwbuff(3)) call nvtxEndRange end if @@ -746,11 +630,9 @@ contains ! Dimensional Splitting Loop do id = 1, num_dims - if (igr .or. dummy) then - if (id == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do l = -1, p + 1 do k = -1, n + 1 do j = -1, m + 1 @@ -777,7 +659,7 @@ contains call nvtxEndRange end if end if - if ((.not. igr) .or. dummy) then! Finite volume solve + if ((.not. igr) .or. dummy) then ! Finite volume solve ! Reconstructing Primitive/Conservative Variables call nvtxStartRange("RHS-WENO") @@ -786,97 +668,66 @@ contains if (all(Re_size == 0)) then ! Reconstruct densitiess iv%beg = 1; iv%end = sys_size - call s_reconstruct_cell_boundary_values( & - q_prim_qp%vf(1:sys_size), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values(q_prim_qp%vf(1:sys_size), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) else iv%beg = 1; iv%end = contxe - call s_reconstruct_cell_boundary_values( & - q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = sys_size - call s_reconstruct_cell_boundary_values( & - q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) end if - else if (all(Re_size == 0)) then iv%beg = 1; iv%end = E_idx - 1 - call s_reconstruct_cell_boundary_values( & - q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = E_idx - call s_reconstruct_cell_boundary_values_first_order( & - q_prim_qp%vf(E_idx), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values_first_order(q_prim_qp%vf(E_idx), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx + 1; iv%end = sys_size - call s_reconstruct_cell_boundary_values( & - q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) else iv%beg = 1; iv%end = contxe - call s_reconstruct_cell_boundary_values( & - q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = E_idx - call s_reconstruct_cell_boundary_values_first_order( & - q_prim_qp%vf(E_idx), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values_first_order(q_prim_qp%vf(E_idx), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx + 1; iv%end = sys_size - call s_reconstruct_cell_boundary_values( & - q_prim_qp%vf(iv%beg:iv%end), & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - id) + call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) end if - end if ! Reconstruct viscous derivatives for viscosity if (weno_Re_flux) then iv%beg = momxb; iv%end = momxe - call s_reconstruct_cell_boundary_values_visc_deriv( & - dq_prim_dx_qp(1)%vf(iv%beg:iv%end), & - dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, & - dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, & - id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), dqR_prim_dx_n(id)%vf(iv%beg:iv%end), & - idwbuff(1), idwbuff(2), idwbuff(3)) + call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dx_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & + & dqR_rsz_vf, id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), & + & dqR_prim_dx_n(id)%vf(iv%beg:iv%end), idwbuff(1), & + & idwbuff(2), idwbuff(3)) if (n > 0) then - call s_reconstruct_cell_boundary_values_visc_deriv( & - dq_prim_dy_qp(1)%vf(iv%beg:iv%end), & - dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, & - dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, & - id, dqL_prim_dy_n(id)%vf(iv%beg:iv%end), dqR_prim_dy_n(id)%vf(iv%beg:iv%end), & - idwbuff(1), idwbuff(2), idwbuff(3)) + call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dy_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & + & dqR_rsz_vf, id, dqL_prim_dy_n(id)%vf(iv%beg:iv%end), & + & dqR_prim_dy_n(id)%vf(iv%beg:iv%end), idwbuff(1), & + & idwbuff(2), idwbuff(3)) if (p > 0) then - call s_reconstruct_cell_boundary_values_visc_deriv( & - dq_prim_dz_qp(1)%vf(iv%beg:iv%end), & - dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, & - dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, & - id, dqL_prim_dz_n(id)%vf(iv%beg:iv%end), dqR_prim_dz_n(id)%vf(iv%beg:iv%end), & - idwbuff(1), idwbuff(2), idwbuff(3)) + call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dz_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & + & dqR_rsz_vf, id, & + & dqL_prim_dz_n(id)%vf(iv%beg:iv%end), & + & dqR_prim_dz_n(id)%vf(iv%beg:iv%end), idwbuff(1), & + & idwbuff(2), idwbuff(3)) end if end if end if @@ -886,7 +737,7 @@ contains ! Configuring Coordinate Direction Indexes if (id == 1) then irx%beg = -1; iry%beg = 0; irz%beg = 0 - elseif (id == 2) then + else if (id == 2) then irx%beg = 0; iry%beg = -1; irz%beg = 0 else irx%beg = 0; iry%beg = 0; irz%beg = -1 @@ -896,43 +747,26 @@ contains ! print *, "L", qL_rsx_vf(100:300, 0, 0, 1) ! print *, "R", qR_rsx_vf(100:300, 0, 0, 1) - !Computing Riemann Solver Flux and Source Flux + ! Computing Riemann Solver Flux and Source Flux call nvtxStartRange("RHS-RIEMANN-SOLVER") - call s_riemann_solver(qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, & - dqR_prim_dx_n(id)%vf, & - dqR_prim_dy_n(id)%vf, & - dqR_prim_dz_n(id)%vf, & - qR_prim(id)%vf, & - qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - dqL_prim_dx_n(id)%vf, & - dqL_prim_dy_n(id)%vf, & - dqL_prim_dz_n(id)%vf, & - qL_prim(id)%vf, & - q_prim_qp%vf, & - flux_n(id)%vf, & - flux_src_n(id)%vf, & - flux_gsrc_n(id)%vf, & - id, irx, iry, irz) + call s_riemann_solver(qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n(id)%vf, dqR_prim_dy_n(id)%vf, & + & dqR_prim_dz_n(id)%vf, qR_prim(id)%vf, qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & dqL_prim_dx_n(id)%vf, dqL_prim_dy_n(id)%vf, dqL_prim_dz_n(id)%vf, qL_prim(id)%vf, & + & q_prim_qp%vf, flux_n(id)%vf, flux_src_n(id)%vf, flux_gsrc_n(id)%vf, id, irx, iry, irz) call nvtxEndRange !$:GPU_UPDATE(host='[flux_n(1)%vf(1)%sf]') - !print *, "FLUX", flux_n(1)%vf(1)%sf(100:300, 0, 0) + ! print *, "FLUX", flux_n(1)%vf(1)%sf(100:300, 0, 0) ! Additional physics and source terms ! RHS addition for advection source call nvtxStartRange("RHS-ADVECTION-SRC") - call s_compute_advection_source_term(id, & - rhs_vf, & - q_cons_qp, & - q_prim_qp, & - flux_src_n(id)) + call s_compute_advection_source_term(id, rhs_vf, q_cons_qp, q_prim_qp, flux_src_n(id)) call nvtxEndRange ! RHS additions for hypoelasticity call nvtxStartRange("RHS-HYPOELASTICITY") - if (hypoelasticity) call s_compute_hypoelastic_rhs(id, & - q_prim_qp%vf, & - rhs_vf) + if (hypoelasticity) call s_compute_hypoelastic_rhs(id, q_prim_qp%vf, rhs_vf) call nvtxEndRange ! RHS for diffusion @@ -945,13 +779,8 @@ contains ! RHS additions for viscosity if (viscous .or. surface_tension .or. chem_params%diffusion) then call nvtxStartRange("RHS-ADD-PHYSICS") - call s_compute_additional_physics_rhs(id, & - q_prim_qp%vf, & - rhs_vf, & - flux_src_n(id)%vf, & - dq_prim_dx_qp(1)%vf, & - dq_prim_dy_qp(1)%vf, & - dq_prim_dz_qp(1)%vf) + call s_compute_additional_physics_rhs(id, q_prim_qp%vf, rhs_vf, flux_src_n(id)%vf, dq_prim_dx_qp(1)%vf, & + & dq_prim_dy_qp(1)%vf, dq_prim_dz_qp(1)%vf) call nvtxEndRange end if @@ -965,24 +794,18 @@ contains ! RHS additions for qbmm bubbles if (qbmm) then call nvtxStartRange("RHS-QBMM") - call s_compute_qbmm_rhs(id, & - q_cons_qp%vf, & - q_prim_qp%vf, & - rhs_vf, & - flux_n(id)%vf, & - pb_in, & - rhs_pb) + call s_compute_qbmm_rhs(id, q_cons_qp%vf, q_prim_qp%vf, rhs_vf, flux_n(id)%vf, pb_in, rhs_pb) call nvtxEndRange end if ! END: Additional physics and source terms if (hyper_cleaning) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - rhs_vf(psi_idx)%sf(j, k, l) = rhs_vf(psi_idx)%sf(j, k, l) - & - q_prim_vf(psi_idx)%sf(j, k, l)/hyper_cleaning_tau + rhs_vf(psi_idx)%sf(j, k, l) = rhs_vf(psi_idx)%sf(j, k, l) - q_prim_vf(psi_idx)%sf(j, k, & + & l)/hyper_cleaning_tau end do end do end do @@ -995,7 +818,7 @@ contains ! END: Dimensional Splitting Loop if (ib) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m @@ -1014,37 +837,26 @@ contains ! Additions for acoustic_source if (acoustic_source) then call nvtxStartRange("RHS-ACOUSTIC-SRC") - call s_acoustic_src_calculations(q_cons_qp%vf(1:sys_size), & - q_prim_qp%vf(1:sys_size), & - rhs_vf) + call s_acoustic_src_calculations(q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), rhs_vf) call nvtxEndRange end if ! Add bubbles source term if (bubbles_euler .and. (.not. adap_dt) .and. (.not. qbmm)) then call nvtxStartRange("RHS-BUBBLES-SRC") - call s_compute_bubble_EE_source( & - q_cons_qp%vf(1:sys_size), & - q_prim_qp%vf(1:sys_size), & - rhs_vf, & - divu) + call s_compute_bubble_EE_source(q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), rhs_vf, divu) call nvtxEndRange end if if (bubbles_lagrange) then ! RHS additions for sub-grid bubbles_lagrange call nvtxStartRange("RHS-EL-BUBBLES-SRC") - call s_compute_bubbles_EL_source( & - q_cons_qp%vf(1:sys_size), & - q_prim_qp%vf(1:sys_size), & - rhs_vf) + call s_compute_bubbles_EL_source(q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), rhs_vf) call nvtxEndRange ! Compute bubble dynamics if (.not. adap_dt) then call nvtxStartRange("RHS-EL-BUBBLES-DYN") - call s_compute_bubble_EL_dynamics( & - q_prim_qp%vf(1:sys_size), & - stage) + call s_compute_bubble_EL_dynamics(q_prim_qp%vf(1:sys_size), stage) call nvtxEndRange end if end if @@ -1061,7 +873,7 @@ contains if (run_time_info .or. probe_wrt .or. ib .or. bubbles_lagrange) then if (.not. igr .or. dummy) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = 1, sys_size do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end @@ -1084,34 +896,29 @@ contains end if call nvtxEndRange - end subroutine s_compute_rhs - !> @brief Accumulates advection source contributions from a given coordinate direction into the RHS. subroutine s_compute_advection_source_term(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf) - - integer, intent(in) :: idir + integer, intent(in) :: idir type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - type(vector_field), intent(inout) :: q_cons_vf - type(vector_field), intent(inout) :: q_prim_vf - type(vector_field), intent(inout) :: flux_src_n_vf - - integer :: j, k, l, q ! Loop iterators from original, meaning varies - integer :: k_loop, l_loop, q_loop ! Standardized spatial loop iterators 0:m, 0:n, 0:p - integer :: i_fluid_loop - - real(wp) :: inv_ds, flux_face1, flux_face2 - real(wp) :: advected_qty_val, pressure_val, velocity_val + type(vector_field), intent(inout) :: q_cons_vf + type(vector_field), intent(inout) :: q_prim_vf + type(vector_field), intent(inout) :: flux_src_n_vf + integer :: j, k, l, q ! Loop iterators from original, meaning varies + integer :: k_loop, l_loop, q_loop ! Standardized spatial loop iterators 0:m, 0:n, 0:p + integer :: i_fluid_loop + real(wp) :: inv_ds, flux_face1, flux_face2 + real(wp) :: advected_qty_val, pressure_val, velocity_val if (alt_soundspeed) then - $:GPU_PARALLEL_LOOP(private='[k_loop,l_loop,q_loop]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[k_loop, l_loop, q_loop]', collapse=3) do q_loop = 0, p do l_loop = 0, n do k_loop = 0, m - blkmod1(k_loop, l_loop, q_loop) = ((gammas(1) + 1._wp)*q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, q_loop) + & - pi_infs(1))/gammas(1) - blkmod2(k_loop, l_loop, q_loop) = ((gammas(2) + 1._wp)*q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, q_loop) + & - pi_infs(2))/gammas(2) + blkmod1(k_loop, l_loop, q_loop) = ((gammas(1) + 1._wp)*q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, & + & q_loop) + pi_infs(1))/gammas(1) + blkmod2(k_loop, l_loop, q_loop) = ((gammas(2) + 1._wp)*q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, & + & q_loop) + pi_infs(2))/gammas(2) alpha1(k_loop, l_loop, q_loop) = q_cons_vf%vf(advxb)%sf(k_loop, l_loop, q_loop) if (bubbles_euler) then @@ -1120,10 +927,10 @@ contains alpha2(k_loop, l_loop, q_loop) = q_cons_vf%vf(advxe)%sf(k_loop, l_loop, q_loop) end if - Kterm(k_loop, l_loop, q_loop) = alpha1(k_loop, l_loop, q_loop)*alpha2(k_loop, l_loop, q_loop)* & - (blkmod2(k_loop, l_loop, q_loop) - blkmod1(k_loop, l_loop, q_loop))/ & - (alpha1(k_loop, l_loop, q_loop)*blkmod2(k_loop, l_loop, q_loop) + & - alpha2(k_loop, l_loop, q_loop)*blkmod1(k_loop, l_loop, q_loop)) + Kterm(k_loop, l_loop, q_loop) = alpha1(k_loop, l_loop, q_loop)*alpha2(k_loop, l_loop, & + & q_loop)*(blkmod2(k_loop, l_loop, q_loop) - blkmod1(k_loop, l_loop, q_loop))/(alpha1(k_loop, & + & l_loop, q_loop)*blkmod2(k_loop, l_loop, q_loop) + alpha2(k_loop, l_loop, q_loop)*blkmod1(k_loop, & + & l_loop, q_loop)) end do end do end do @@ -1131,7 +938,7 @@ contains end if select case (idir) - case (1) ! x-direction + case (1) ! x-direction if (bc_x%beg <= BC_CHAR_SLIP_WALL .and. bc_x%beg >= BC_CHAR_SUP_OUTFLOW) then call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, -1, irx, iry, irz) end if @@ -1139,7 +946,7 @@ contains call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, 1, irx, iry, irz) end if - $:GPU_PARALLEL_LOOP(collapse=4,private='[j,k_loop,l_loop,q_loop,inv_ds,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j, k_loop, l_loop, q_loop, inv_ds, flux_face1, flux_face2]') do j = 1, sys_size do q_loop = 0, p do l_loop = 0, n @@ -1155,7 +962,8 @@ contains $:END_GPU_PARALLEL_LOOP() if (model_eqns == 3) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop,k_loop,l_loop,q_loop,inv_ds,advected_qty_val, pressure_val,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop, k_loop, l_loop, q_loop, inv_ds, advected_qty_val, & + & pressure_val, flux_face1, flux_face2]') do q_loop = 0, p do l_loop = 0, n do k_loop = 0, m @@ -1165,9 +973,9 @@ contains pressure_val = q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, q_loop) flux_face1 = flux_src_n_vf%vf(advxb)%sf(k_loop, l_loop, q_loop) flux_face2 = flux_src_n_vf%vf(advxb)%sf(k_loop - 1, l_loop, q_loop) - rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, q_loop) = & - rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, q_loop) - & - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, & + & q_loop) = rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, & + & q_loop) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) end do end do end do @@ -1176,7 +984,6 @@ contains end if call s_add_directional_advection_source_terms(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf, Kterm) - case (2) ! y-direction if (bc_y%beg <= BC_CHAR_SLIP_WALL .and. bc_y%beg >= BC_CHAR_SUP_OUTFLOW) then call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, -1, irx, iry, irz) @@ -1185,7 +992,7 @@ contains call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, 1, irx, iry, irz) end if - $:GPU_PARALLEL_LOOP(collapse=4,private='[j,k,l,q,inv_ds,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j, k, l, q, inv_ds, flux_face1, flux_face2]') do j = 1, sys_size do l = 0, p do k = 0, n @@ -1201,7 +1008,7 @@ contains $:END_GPU_PARALLEL_LOOP() if (model_eqns == 3) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop,k,l,q,inv_ds,advected_qty_val, pressure_val,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop, k, l, q, inv_ds, advected_qty_val, pressure_val, flux_face1, flux_face2]') do l = 0, p do k = 0, n do q = 0, m @@ -1211,13 +1018,11 @@ contains pressure_val = q_prim_vf%vf(E_idx)%sf(q, k, l) flux_face1 = flux_src_n_vf%vf(advxb)%sf(q, k, l) flux_face2 = flux_src_n_vf%vf(advxb)%sf(q, k - 1, l) - rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) = & - rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) - & - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) = rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, & + & l) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) if (cyl_coord) then - rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) = & - rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) - & - 5.e-1_wp/y_cc(k)*advected_qty_val*pressure_val*(flux_face1 + flux_face2) + rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) = rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, & + & l) - 5.e-1_wp/y_cc(k)*advected_qty_val*pressure_val*(flux_face1 + flux_face2) end if end do end do @@ -1227,15 +1032,14 @@ contains end if if (cyl_coord) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[j,k,l,q,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j, k, l, q, flux_face1, flux_face2]') do j = 1, sys_size do l = 0, p do k = 0, n do q = 0, m flux_face1 = flux_gsrc_n(2)%vf(j)%sf(q, k - 1, l) flux_face2 = flux_gsrc_n(2)%vf(j)%sf(q, k, l) - rhs_vf(j)%sf(q, k, l) = rhs_vf(j)%sf(q, k, l) - & - 5.e-1_wp/y_cc(k)*(flux_face1 + flux_face2) + rhs_vf(j)%sf(q, k, l) = rhs_vf(j)%sf(q, k, l) - 5.e-1_wp/y_cc(k)*(flux_face1 + flux_face2) end do end do end do @@ -1244,7 +1048,6 @@ contains end if call s_add_directional_advection_source_terms(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf, Kterm) - case (3) ! z-direction if (bc_z%beg <= BC_CHAR_SLIP_WALL .and. bc_z%beg >= BC_CHAR_SUP_OUTFLOW) then call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, -1, irx, iry, irz) @@ -1254,7 +1057,7 @@ contains end if if (grid_geometry == 3) then ! Cylindrical Coordinates - $:GPU_PARALLEL_LOOP(collapse=4,private='[j,k,l,q,inv_ds,velocity_val,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j, k, l, q, inv_ds, velocity_val, flux_face1, flux_face2]') do j = 1, sys_size do k = 0, p do q = 0, n @@ -1263,29 +1066,27 @@ contains velocity_val = q_prim_vf%vf(contxe + idir)%sf(l, q, k) flux_face1 = flux_n(3)%vf(j)%sf(l, q, k - 1) flux_face2 = flux_n(3)%vf(j)%sf(l, q, k) - rhs_vf(j)%sf(l, q, k) = rhs_vf(j)%sf(l, q, k) + & - inv_ds*velocity_val*(flux_face1 - flux_face2) + rhs_vf(j)%sf(l, q, k) = rhs_vf(j)%sf(l, q, k) + inv_ds*velocity_val*(flux_face1 - flux_face2) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(collapse=4,private='[j,k,l,q,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j, k, l, q, flux_face1, flux_face2]') do j = 1, sys_size do k = 0, p do q = 0, n do l = 0, m flux_face1 = flux_gsrc_n(3)%vf(j)%sf(l, q, k - 1) flux_face2 = flux_gsrc_n(3)%vf(j)%sf(l, q, k) - rhs_vf(j)%sf(l, q, k) = rhs_vf(j)%sf(l, q, k) - & - 5.e-1_wp/y_cc(q)*(flux_face1 + flux_face2) + rhs_vf(j)%sf(l, q, k) = rhs_vf(j)%sf(l, q, k) - 5.e-1_wp/y_cc(q)*(flux_face1 + flux_face2) end do end do end do end do $:END_GPU_PARALLEL_LOOP() else ! Cartesian Coordinates - $:GPU_PARALLEL_LOOP(collapse=4,private='[j,k,l,q,inv_ds,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j, k, l, q, inv_ds, flux_face1, flux_face2]') do j = 1, sys_size do k = 0, p do q = 0, n @@ -1302,7 +1103,7 @@ contains end if if (model_eqns == 3) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop,k,l,q,inv_ds,advected_qty_val, pressure_val,flux_face1,flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop, k, l, q, inv_ds, advected_qty_val, pressure_val, flux_face1, flux_face2]') do k = 0, p do q = 0, n do l = 0, m @@ -1312,9 +1113,8 @@ contains pressure_val = q_prim_vf%vf(E_idx)%sf(l, q, k) flux_face1 = flux_src_n_vf%vf(advxb)%sf(l, q, k) flux_face2 = flux_src_n_vf%vf(advxb)%sf(l, q, k - 1) - rhs_vf(i_fluid_loop + intxb - 1)%sf(l, q, k) = & - rhs_vf(i_fluid_loop + intxb - 1)%sf(l, q, k) - & - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + rhs_vf(i_fluid_loop + intxb - 1)%sf(l, q, k) = rhs_vf(i_fluid_loop + intxb - 1)%sf(l, q, & + & k) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) end do end do end do @@ -1323,32 +1123,30 @@ contains end if call s_add_directional_advection_source_terms(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf, Kterm) - end select - contains !> @brief Adds the advection source flux-difference terms for a single coordinate direction to the RHS. - subroutine s_add_directional_advection_source_terms(current_idir, rhs_vf_arg, q_cons_vf_arg, & - q_prim_vf_arg, flux_src_n_vf_arg, Kterm_arg) - integer, intent(in) :: current_idir + subroutine s_add_directional_advection_source_terms(current_idir, rhs_vf_arg, q_cons_vf_arg, q_prim_vf_arg, & + & flux_src_n_vf_arg, Kterm_arg) + integer, intent(in) :: current_idir type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf_arg - type(vector_field), intent(in) :: q_cons_vf_arg - type(vector_field), intent(in) :: q_prim_vf_arg - type(vector_field), intent(in) :: flux_src_n_vf_arg + type(vector_field), intent(in) :: q_cons_vf_arg + type(vector_field), intent(in) :: q_prim_vf_arg + type(vector_field), intent(in) :: flux_src_n_vf_arg ! CORRECTED DECLARATION FOR Kterm_arg: - real(wp), allocatable, dimension(:, :, :), intent(in) :: Kterm_arg - - integer :: j_adv, k_idx, l_idx, q_idx - real(wp) :: local_inv_ds, local_term_coeff, local_flux1, local_flux2 - real(wp) :: local_q_cons_val, local_k_term_val - logical :: use_standard_riemann + real(wp), allocatable, dimension(:,:,:), intent(in) :: Kterm_arg + integer :: j_adv, k_idx, l_idx, q_idx + real(wp) :: local_inv_ds, local_term_coeff, local_flux1, local_flux2 + real(wp) :: local_q_cons_val, local_k_term_val + logical :: use_standard_riemann select case (current_idir) case (1) ! x-direction use_standard_riemann = (riemann_solver == 1 .or. riemann_solver == 4) if (use_standard_riemann) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv,k_idx,l_idx,q_idx,local_inv_ds, local_term_coeff,local_flux1,local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & + & local_flux1, local_flux2]') do j_adv = advxb, advxe do q_idx = 0, p ! z_extent do l_idx = 0, n ! y_extent @@ -1357,8 +1155,8 @@ contains local_term_coeff = q_prim_vf_arg%vf(contxe + current_idir)%sf(k_idx, l_idx, q_idx) local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx - 1, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) - rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(j_adv)%sf(k_idx, l_idx, & + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1367,52 +1165,56 @@ contains else ! Other Riemann solvers if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then - $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx,l_idx,q_idx,local_inv_ds, local_q_cons_val, local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do q_idx = 0, p; do l_idx = 0, n; do k_idx = 0, m - local_inv_ds = 1._wp/dx(k_idx) - local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) - local_k_term_val = Kterm_arg(k_idx, l_idx, q_idx) ! Access is safe due to outer alt_soundspeed check - local_term_coeff = local_q_cons_val - local_k_term_val - local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) - local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx - 1, l_idx, q_idx) - rhs_vf_arg(advxe)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(advxe)%sf(k_idx, l_idx, q_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - end do; end do; end do + local_inv_ds = 1._wp/dx(k_idx) + local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) + local_k_term_val = Kterm_arg(k_idx, l_idx, q_idx) ! Access is safe due to outer alt_soundspeed check + local_term_coeff = local_q_cons_val - local_k_term_val + local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) + local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx - 1, l_idx, q_idx) + rhs_vf_arg(advxe)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(advxe)%sf(k_idx, l_idx, & + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + end do; end do; end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx,l_idx,q_idx,local_inv_ds,local_q_cons_val, local_k_term_val,local_term_coeff, local_flux1, local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do q_idx = 0, p; do l_idx = 0, n; do k_idx = 0, m - local_inv_ds = 1._wp/dx(k_idx) - local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) - local_k_term_val = Kterm_arg(k_idx, l_idx, q_idx) ! Access is safe - local_term_coeff = local_q_cons_val + local_k_term_val - local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) - local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx - 1, l_idx, q_idx) - rhs_vf_arg(advxb)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(advxb)%sf(k_idx, l_idx, q_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - end do; end do; end do + local_inv_ds = 1._wp/dx(k_idx) + local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) + local_k_term_val = Kterm_arg(k_idx, l_idx, q_idx) ! Access is safe + local_term_coeff = local_q_cons_val + local_k_term_val + local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) + local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx - 1, l_idx, q_idx) + rhs_vf_arg(advxb)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(advxb)%sf(k_idx, l_idx, & + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if else ! NOT alt_soundspeed - $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv,k_idx,l_idx,q_idx,local_inv_ds, local_term_coeff,local_flux1,local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & + & local_flux1, local_flux2]') do j_adv = advxb, advxe do q_idx = 0, p; do l_idx = 0, n; do k_idx = 0, m - local_inv_ds = 1._wp/dx(k_idx) - local_term_coeff = q_cons_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) - local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) - local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx - 1, l_idx, q_idx) - rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - end do; end do; end do + local_inv_ds = 1._wp/dx(k_idx) + local_term_coeff = q_cons_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) + local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) + local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx - 1, l_idx, q_idx) + rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(j_adv)%sf(k_idx, l_idx, & + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() end if end if - - case (2) ! y-direction: loops q_idx (x), k_idx (y), l_idx (z); sf(q_idx, k_idx, l_idx); dy(k_idx); Kterm(q_idx,k_idx,l_idx) + case (2) & + & ! y-direction: loops q_idx (x), k_idx (y), l_idx (z); sf(q_idx, k_idx, l_idx); dy(k_idx); Kterm(q_idx,k_idx,l_idx) use_standard_riemann = (riemann_solver == 1 .or. riemann_solver == 4) if (use_standard_riemann) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv,k_idx,l_idx,q_idx,local_inv_ds, local_term_coeff,local_flux1,local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & + & local_flux1, local_flux2]') do j_adv = advxb, advxe do l_idx = 0, p ! z_extent do k_idx = 0, n ! y_extent @@ -1421,8 +1223,8 @@ contains local_term_coeff = q_prim_vf_arg%vf(contxe + current_idir)%sf(q_idx, k_idx, l_idx) local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx - 1, l_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) - rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(j_adv)%sf(q_idx, k_idx, & + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1431,57 +1233,60 @@ contains else ! Other Riemann solvers if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then - $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx,l_idx,q_idx,local_inv_ds, local_q_cons_val, local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do l_idx = 0, p; do k_idx = 0, n; do q_idx = 0, m - local_inv_ds = 1._wp/dy(k_idx) - local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) - local_k_term_val = Kterm_arg(q_idx, k_idx, l_idx) ! Access is safe - local_term_coeff = local_q_cons_val - local_k_term_val - local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) - local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx - 1, l_idx) - rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - if (cyl_coord) then - rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) - & - (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) - end if - end do; end do; end do + local_inv_ds = 1._wp/dy(k_idx) + local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) + local_k_term_val = Kterm_arg(q_idx, k_idx, l_idx) ! Access is safe + local_term_coeff = local_q_cons_val - local_k_term_val + local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) + local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx - 1, l_idx) + rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxe)%sf(q_idx, k_idx, & + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + if (cyl_coord) then + rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxe)%sf(q_idx, k_idx, & + & l_idx) - (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) + end if + end do; end do; end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx,l_idx,q_idx,local_inv_ds, local_q_cons_val, local_k_term_val,local_term_coeff, local_flux1, local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do l_idx = 0, p; do k_idx = 0, n; do q_idx = 0, m - local_inv_ds = 1._wp/dy(k_idx) - local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) - local_k_term_val = Kterm_arg(q_idx, k_idx, l_idx) ! Access is safe - local_term_coeff = local_q_cons_val + local_k_term_val - local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) - local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx - 1, l_idx) - rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - if (cyl_coord) then - rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) + & - (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) - end if - end do; end do; end do + local_inv_ds = 1._wp/dy(k_idx) + local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) + local_k_term_val = Kterm_arg(q_idx, k_idx, l_idx) ! Access is safe + local_term_coeff = local_q_cons_val + local_k_term_val + local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) + local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx - 1, l_idx) + rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxb)%sf(q_idx, k_idx, & + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + if (cyl_coord) then + rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxb)%sf(q_idx, k_idx, & + & l_idx) + (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) + end if + end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if else ! NOT alt_soundspeed - $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv,k_idx,l_idx,q_idx,local_inv_ds, local_term_coeff,local_flux1,local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & + & local_flux1, local_flux2]') do j_adv = advxb, advxe do l_idx = 0, p; do k_idx = 0, n; do q_idx = 0, m - local_inv_ds = 1._wp/dy(k_idx) - local_term_coeff = q_cons_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) - local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) - local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx - 1, l_idx) - rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - end do; end do; end do + local_inv_ds = 1._wp/dy(k_idx) + local_term_coeff = q_cons_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) + local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) + local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx - 1, l_idx) + rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(j_adv)%sf(q_idx, k_idx, & + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() end if end if - - case (3) ! z-direction: loops l_idx (x), q_idx (y), k_idx (z); sf(l_idx, q_idx, k_idx); dz(k_idx); Kterm(l_idx,q_idx,k_idx) + case (3) & + & ! z-direction: loops l_idx (x), q_idx (y), k_idx (z); sf(l_idx, q_idx, k_idx); dz(k_idx); Kterm(l_idx,q_idx,k_idx) if (grid_geometry == 3) then use_standard_riemann = (riemann_solver == 1) else @@ -1489,7 +1294,8 @@ contains end if if (use_standard_riemann) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv,k_idx,l_idx,q_idx,local_inv_ds, local_term_coeff,local_flux1,local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & + & local_flux1, local_flux2]') do j_adv = advxb, advxe do k_idx = 0, p ! z_extent do q_idx = 0, n ! y_extent @@ -1498,8 +1304,8 @@ contains local_term_coeff = q_prim_vf_arg%vf(contxe + current_idir)%sf(l_idx, q_idx, k_idx) local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx - 1) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) - rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(j_adv)%sf(l_idx, q_idx, & + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1508,76 +1314,71 @@ contains else ! Other Riemann solvers if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then - $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx,l_idx,q_idx,local_inv_ds,local_q_cons_val, local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do k_idx = 0, p; do q_idx = 0, n; do l_idx = 0, m - local_inv_ds = 1._wp/dz(k_idx) - local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) - local_k_term_val = Kterm_arg(l_idx, q_idx, k_idx) ! Access is safe - local_term_coeff = local_q_cons_val - local_k_term_val - local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) - local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx - 1) - rhs_vf_arg(advxe)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(advxe)%sf(l_idx, q_idx, k_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - end do; end do; end do + local_inv_ds = 1._wp/dz(k_idx) + local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) + local_k_term_val = Kterm_arg(l_idx, q_idx, k_idx) ! Access is safe + local_term_coeff = local_q_cons_val - local_k_term_val + local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) + local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx - 1) + rhs_vf_arg(advxe)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(advxe)%sf(l_idx, q_idx, & + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + end do; end do; end do $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx,l_idx,q_idx,local_inv_ds, local_q_cons_val, local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do k_idx = 0, p; do q_idx = 0, n; do l_idx = 0, m - local_inv_ds = 1._wp/dz(k_idx) - local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) - local_k_term_val = Kterm_arg(l_idx, q_idx, k_idx) ! Access is safe - local_term_coeff = local_q_cons_val + local_k_term_val - local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) - local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx - 1) - rhs_vf_arg(advxb)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(advxb)%sf(l_idx, q_idx, k_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - end do; end do; end do + local_inv_ds = 1._wp/dz(k_idx) + local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) + local_k_term_val = Kterm_arg(l_idx, q_idx, k_idx) ! Access is safe + local_term_coeff = local_q_cons_val + local_k_term_val + local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) + local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx - 1) + rhs_vf_arg(advxb)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(advxb)%sf(l_idx, q_idx, & + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if else ! NOT alt_soundspeed - $:GPU_PARALLEL_LOOP(collapse=4, private='[j_adv,k_idx,l_idx,q_idx,local_inv_ds, local_term_coeff,local_flux1,local_flux2]') + $:GPU_PARALLEL_LOOP(collapse=4, private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & + & local_flux1, local_flux2]') do j_adv = advxb, advxe do k_idx = 0, p; do q_idx = 0, n; do l_idx = 0, m - local_inv_ds = 1._wp/dz(k_idx) - local_term_coeff = q_cons_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) - local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) - local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx - 1) - rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) + & - local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) - end do; end do; end do + local_inv_ds = 1._wp/dz(k_idx) + local_term_coeff = q_cons_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) + local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) + local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx - 1) + rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(j_adv)%sf(l_idx, q_idx, & + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() end if end if end select end subroutine s_add_directional_advection_source_terms - end subroutine s_compute_advection_source_term - !> @brief Adds viscous, surface-tension, and species-diffusion source flux contributions to the RHS for a given direction. - subroutine s_compute_additional_physics_rhs(idir, q_prim_vf, rhs_vf, flux_src_n_in, & - dq_prim_dx_vf, dq_prim_dy_vf, dq_prim_dz_vf) - - integer, intent(in) :: idir - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + subroutine s_compute_additional_physics_rhs(idir, q_prim_vf, rhs_vf, flux_src_n_in, dq_prim_dx_vf, dq_prim_dy_vf, dq_prim_dz_vf) + integer, intent(in) :: idir + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - type(scalar_field), dimension(sys_size), intent(in) :: flux_src_n_in - type(scalar_field), dimension(sys_size), intent(in) :: dq_prim_dx_vf, dq_prim_dy_vf, dq_prim_dz_vf - - integer :: i, j, k, l + type(scalar_field), dimension(sys_size), intent(in) :: flux_src_n_in + type(scalar_field), dimension(sys_size), intent(in) :: dq_prim_dx_vf, dq_prim_dy_vf, dq_prim_dz_vf + integer :: i, j, k, l if (idir == 1) then ! x-direction if (surface_tension) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - rhs_vf(c_idx)%sf(j, k, l) = & - rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dx(j)* & - q_prim_vf(c_idx)%sf(j, k, l)* & - (flux_src_n_in(advxb)%sf(j, k, l) - & - flux_src_n_in(advxb)%sf(j - 1, k, l)) + rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dx(j)*q_prim_vf(c_idx)%sf(j, k, & + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j - 1, k, l)) end do end do end do @@ -1585,34 +1386,29 @@ contains end if if ((surface_tension .or. viscous) .or. chem_params%diffusion) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m if (surface_tension .or. viscous) then $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)* & - (flux_src_n_in(i)%sf(j - 1, k, l) & - - flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)*(flux_src_n_in(i)%sf(j - 1, k, & + & l) - flux_src_n_in(i)%sf(j, k, l)) end do end if if (chem_params%diffusion) then $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)* & - (flux_src_n_in(i)%sf(j - 1, k, l) & - - flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)*(flux_src_n_in(i)%sf(j - 1, k, & + & l) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then - rhs_vf(E_idx)%sf(j, k, l) = & - rhs_vf(E_idx)%sf(j, k, l) + 1._wp/dx(j)* & - (flux_src_n_in(E_idx)%sf(j - 1, k, l) & - - flux_src_n_in(E_idx)%sf(j, k, l)) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + 1._wp/dx(j)*(flux_src_n_in(E_idx)%sf(j - 1, k, l) - flux_src_n_in(E_idx)%sf(j, & + & k, l)) end if end if end do @@ -1620,19 +1416,15 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - - elseif (idir == 2) then ! y-direction + else if (idir == 2) then ! y-direction if (surface_tension) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - rhs_vf(c_idx)%sf(j, k, l) = & - rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dy(k)* & - q_prim_vf(c_idx)%sf(j, k, l)* & - (flux_src_n_in(advxb)%sf(j, k, l) - & - flux_src_n_in(advxb)%sf(j, k - 1, l)) + rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dy(k)*q_prim_vf(c_idx)%sf(j, k, & + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k - 1, l)) end do end do end do @@ -1642,83 +1434,68 @@ contains if (cyl_coord .and. ((bc_y%beg == -2) .or. (bc_y%beg == -14))) then if (viscous .or. dummy) then if (p > 0) then - call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, & - dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & - dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & - dq_prim_dz_vf(mom_idx%beg:mom_idx%end), & - tau_Re_vf, & - idwbuff(1), idwbuff(2), idwbuff(3)) + call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & + & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & + & dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & + & idwbuff(1), idwbuff(2), idwbuff(3)) else - call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, & - dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & - dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & - dq_prim_dz_vf(mom_idx%beg:mom_idx%end), & - tau_Re_vf, & - idwbuff(1), idwbuff(2), idwbuff(3)) + call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & + & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & + & dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & + & idwbuff(1), idwbuff(2), idwbuff(3)) end if - $:GPU_PARALLEL_LOOP(private='[i,j,l]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, l]', collapse=2) do l = 0, p do j = 0, m $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx - rhs_vf(i)%sf(j, 0, l) = & - rhs_vf(i)%sf(j, 0, l) + 1._wp/(y_cc(1) - y_cc(-1))* & - (tau_Re_vf(i)%sf(j, -1, l) & - - tau_Re_vf(i)%sf(j, 1, l)) + rhs_vf(i)%sf(j, 0, l) = rhs_vf(i)%sf(j, 0, l) + 1._wp/(y_cc(1) - y_cc(-1))*(tau_Re_vf(i)%sf(j, & + & -1, l) - tau_Re_vf(i)%sf(j, 1, l)) end do end do end do $:END_GPU_PARALLEL_LOOP() - end if - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) do l = 0, p do k = 1, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)* & - (flux_src_n_in(i)%sf(j, k - 1, l) & - - flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, k - 1, & + & l) - flux_src_n_in(i)%sf(j, k, l)) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - else if ((surface_tension .or. viscous) .or. chem_params%diffusion) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m if (surface_tension .or. viscous) then $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)* & - (flux_src_n_in(i)%sf(j, k - 1, l) & - - flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, & + & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) end do end if if (chem_params%diffusion) then $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)* & - (flux_src_n_in(i)%sf(j, k - 1, l) & - - flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, & + & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then - rhs_vf(E_idx)%sf(j, k, l) = & - rhs_vf(E_idx)%sf(j, k, l) + 1._wp/dy(k)* & - (flux_src_n_in(E_idx)%sf(j, k - 1, l) & - - flux_src_n_in(E_idx)%sf(j, k, l)) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + 1._wp/dy(k)*(flux_src_n_in(E_idx)%sf(j, k - 1, & + & l) - flux_src_n_in(E_idx)%sf(j, k, l)) end if end if end do @@ -1732,17 +1509,14 @@ contains ! of values at cell boundaries if (cyl_coord) then if ((bc_y%beg == -2) .or. (bc_y%beg == -14)) then - - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) do l = 0, p do k = 1, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) - 5.e-1_wp/y_cc(k)* & - (flux_src_n_in(i)%sf(j, k - 1, l) & - + flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - 5.e-1_wp/y_cc(k)*(flux_src_n_in(i)%sf(j, & + & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) end do end do end do @@ -1750,14 +1524,12 @@ contains $:END_GPU_PARALLEL_LOOP() if (viscous .or. dummy) then - $:GPU_PARALLEL_LOOP(private='[i,j,l]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, l]', collapse=2) do l = 0, p do j = 0, m $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx - rhs_vf(i)%sf(j, 0, l) = & - rhs_vf(i)%sf(j, 0, l) - 1._wp/y_cc(0)* & - tau_Re_vf(i)%sf(j, 0, l) + rhs_vf(i)%sf(j, 0, l) = rhs_vf(i)%sf(j, 0, l) - 1._wp/y_cc(0)*tau_Re_vf(i)%sf(j, 0, l) end do end do end do @@ -1765,16 +1537,14 @@ contains end if else - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) - 5.e-1_wp/y_cc(k)* & - (flux_src_n_in(i)%sf(j, k - 1, l) & - + flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - 5.e-1_wp/y_cc(k)*(flux_src_n_in(i)%sf(j, & + & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) end do end do end do @@ -1782,19 +1552,15 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if - - elseif (idir == 3) then ! z-direction + else if (idir == 3) then ! z-direction if (surface_tension) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - rhs_vf(c_idx)%sf(j, k, l) = & - rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dz(l)* & - q_prim_vf(c_idx)%sf(j, k, l)* & - (flux_src_n_in(advxb)%sf(j, k, l) - & - flux_src_n_in(advxb)%sf(j, k, l - 1)) + rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dz(l)*q_prim_vf(c_idx)%sf(j, k, & + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k, l - 1)) end do end do end do @@ -1802,33 +1568,28 @@ contains end if if ((surface_tension .or. viscous) .or. chem_params%diffusion) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m if (surface_tension .or. viscous) then $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)* & - (flux_src_n_in(i)%sf(j, k, l - 1) & - - flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_src_n_in(i)%sf(j, k, & + & l - 1) - flux_src_n_in(i)%sf(j, k, l)) end do end if if (chem_params%diffusion) then $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe - rhs_vf(i)%sf(j, k, l) = & - rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)* & - (flux_src_n_in(i)%sf(j, k, l - 1) & - - flux_src_n_in(i)%sf(j, k, l)) + rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_src_n_in(i)%sf(j, k, & + & l - 1) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then - rhs_vf(E_idx)%sf(j, k, l) = & - rhs_vf(E_idx)%sf(j, k, l) + 1._wp/dz(l)* & - (flux_src_n_in(E_idx)%sf(j, k, l - 1) & - - flux_src_n_in(E_idx)%sf(j, k, l)) + rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & + & l) + 1._wp/dz(l)*(flux_src_n_in(E_idx)%sf(j, k, l - 1) - flux_src_n_in(E_idx)%sf(j, & + & k, l)) end if end if end do @@ -1838,51 +1599,39 @@ contains end if if (grid_geometry == 3) then - $:GPU_PARALLEL_LOOP(private='[j,k,l]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m - rhs_vf(momxb + 1)%sf(j, k, l) = & - rhs_vf(momxb + 1)%sf(j, k, l) + 5.e-1_wp* & - (flux_src_n_in(momxe)%sf(j, k, l - 1) & - + flux_src_n_in(momxe)%sf(j, k, l)) - - rhs_vf(momxe)%sf(j, k, l) = & - rhs_vf(momxe)%sf(j, k, l) - 5.e-1_wp* & - (flux_src_n_in(momxb + 1)%sf(j, k, l - 1) & - + flux_src_n_in(momxb + 1)%sf(j, k, l)) + rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + 5.e-1_wp*(flux_src_n_in(momxe)%sf(j, & + & k, l - 1) + flux_src_n_in(momxe)%sf(j, k, l)) + + rhs_vf(momxe)%sf(j, k, l) = rhs_vf(momxe)%sf(j, k, l) - 5.e-1_wp*(flux_src_n_in(momxb + 1)%sf(j, k, & + & l - 1) + flux_src_n_in(momxb + 1)%sf(j, k, l)) end do end do end do $:END_GPU_PARALLEL_LOOP() end if end if - end subroutine s_compute_additional_physics_rhs - - !> The purpose of this subroutine is to WENO-reconstruct the - !! left and the right cell-boundary values, including values - !! at the Gaussian quadrature points, from the cell-averaged - !! variables. - !! @param v_vf Cell-average variables - !! @param vL_x Left reconstructed cell-boundary values in x - !! @param vL_y Left reconstructed cell-boundary values in y - !! @param vL_z Left reconstructed cell-boundary values in z - !! @param vR_x Right reconstructed cell-boundary values in x - !! @param vR_y Right reconstructed cell-boundary values in y - !! @param vR_z Right reconstructed cell-boundary values in z - !! @param norm_dir Splitting coordinate direction - subroutine s_reconstruct_cell_boundary_values(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & - norm_dir) - - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + !> The purpose of this subroutine is to WENO-reconstruct the left and the right cell-boundary values, including values at the + !! Gaussian quadrature points, from the cell-averaged variables. + !! @param v_vf Cell-average variables + !! @param vL_x Left reconstructed cell-boundary values in x + !! @param vL_y Left reconstructed cell-boundary values in y + !! @param vL_z Left reconstructed cell-boundary values in z + !! @param vR_x Right reconstructed cell-boundary values in x + !! @param vR_y Right reconstructed cell-boundary values in y + !! @param vR_z Right reconstructed cell-boundary values in z + !! @param norm_dir Splitting coordinate direction + subroutine s_reconstruct_cell_boundary_values(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_x, vR_y, vR_z - integer, intent(in) :: norm_dir - - integer :: recon_dir !< Coordinate direction of the reconstruction - - integer :: i, j, k, l + integer, intent(in) :: norm_dir + integer :: recon_dir !< Coordinate direction of the reconstruction + integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] if (recon_type == ${TYPE}$ .or. dummy) then @@ -1891,12 +1640,10 @@ contains is1 = idwbuff(1); is2 = idwbuff(2); is3 = idwbuff(3) recon_dir = 1; is1%beg = is1%beg + ${SCHEME}$_polyn is1%end = is1%end - ${SCHEME}$_polyn - - elseif (norm_dir == 2) then + else if (norm_dir == 2) then is1 = idwbuff(2); is2 = idwbuff(1); is3 = idwbuff(3) recon_dir = 2; is1%beg = is1%beg + ${SCHEME}$_polyn is1%end = is1%end - ${SCHEME}$_polyn - else is1 = idwbuff(3); is2 = idwbuff(2); is3 = idwbuff(1) recon_dir = 3; is1%beg = is1%beg + ${SCHEME}$_polyn @@ -1905,39 +1652,30 @@ contains if (n > 0) then if (p > 0) then - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, iv%beg:iv%end), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, iv%beg:iv%end), & - recon_dir, & - is1, is2, is3) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & + & :, iv%beg:iv%end), recon_dir, is1, is2, is3) else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, :), & - recon_dir, & - is1, is2, is3) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & + & recon_dir, is1, is2, is3) end if else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, :), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, :), vR_z(:, :, :, :), & - recon_dir, & - is1, is2, is3) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1, is2, is3) end if end if #:endfor end subroutine s_reconstruct_cell_boundary_values - !> @brief Performs first-order (piecewise constant) reconstruction of left and right cell-boundary values. - subroutine s_reconstruct_cell_boundary_values_first_order(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & - norm_dir) - - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + subroutine s_reconstruct_cell_boundary_values_first_order(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_x, vR_y, vR_z - integer, intent(in) :: norm_dir - - integer :: recon_dir !< Coordinate direction of the WENO reconstruction - - integer :: i, j, k, l + integer, intent(in) :: norm_dir + integer :: recon_dir !< Coordinate direction of the WENO reconstruction + integer :: i, j, k, l ! Reconstruction in s1-direction #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl', 'MUSCL_TYPE')] @@ -1946,25 +1684,22 @@ contains is1 = idwbuff(1); is2 = idwbuff(2); is3 = idwbuff(3) recon_dir = 1; is1%beg = is1%beg + ${SCHEME}$_polyn is1%end = is1%end - ${SCHEME}$_polyn - - elseif (norm_dir == 2) then + else if (norm_dir == 2) then is1 = idwbuff(2); is2 = idwbuff(1); is3 = idwbuff(3) recon_dir = 2; is1%beg = is1%beg + ${SCHEME}$_polyn is1%end = is1%end - ${SCHEME}$_polyn - else is1 = idwbuff(3); is2 = idwbuff(2); is3 = idwbuff(1) recon_dir = 3; is1%beg = is1%beg + ${SCHEME}$_polyn is1%end = is1%end - ${SCHEME}$_polyn - end if - $:GPU_UPDATE(device='[is1,is2,is3,iv]') + $:GPU_UPDATE(device='[is1, is2, is3, iv]') end if #:endfor if (recon_dir == 1) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = iv%beg, iv%end do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -1977,7 +1712,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() else if (recon_dir == 2) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = iv%beg, iv%end do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -1990,7 +1725,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() else if (recon_dir == 3) then - $:GPU_PARALLEL_LOOP(private='[i,j,k,l]', collapse=4) + $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=4) do i = iv%beg, iv%end do l = is3%beg, is3%end do k = is2%beg, is2%end @@ -2003,12 +1738,9 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_reconstruct_cell_boundary_values_first_order - !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_rhs_module - integer :: i, j, l call s_finalize_pressure_relaxation_module @@ -2053,7 +1785,6 @@ contains end do if (n > 0) then - do l = mom_idx%beg, mom_idx%end @:DEALLOCATE(dq_prim_dy_qp(1)%vf(l)%sf) end do @@ -2063,7 +1794,6 @@ contains @:DEALLOCATE(dq_prim_dz_qp(1)%vf(l)%sf) end do end if - end if @:DEALLOCATE(dq_prim_dx_qp(1)%vf) @@ -2071,7 +1801,6 @@ contains @:DEALLOCATE(dq_prim_dz_qp(1)%vf) do i = num_dims, 1, -1 - do l = mom_idx%beg, mom_idx%end @:DEALLOCATE(dqL_prim_dx_n(i)%vf(l)%sf) @:DEALLOCATE(dqR_prim_dx_n(i)%vf(l)%sf) @@ -2170,8 +1899,5 @@ contains @:DEALLOCATE(flux_n, flux_src_n, flux_gsrc_n) end if - end subroutine s_finalize_rhs_module - end module m_rhs - diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index c28354d84e..3e4e0f3610 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -9,7 +9,6 @@ #:include 'inline_riemann.fpp' module m_riemann_solvers - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -28,11 +27,8 @@ module m_riemann_solvers 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 + 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 #:if USING_AMD use m_chemistry, only: molecular_weights_nonparameter @@ -40,54 +36,47 @@ module m_riemann_solvers implicit none - private; public :: s_initialize_riemann_solvers_module, & - s_riemann_solver, & - s_hll_riemann_solver, & - s_hllc_riemann_solver, & - s_hlld_riemann_solver, & - s_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. + 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 - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf - $:GPU_DECLARE(create='[flux_rsx_vf,flux_src_rsx_vf,flux_rsy_vf,flux_src_rsy_vf,flux_rsz_vf,flux_src_rsz_vf]') + real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf, flux_src_rsx_vf + real(wp), allocatable, dimension(:,:,:,:) :: flux_rsy_vf, flux_src_rsy_vf + real(wp), allocatable, dimension(:,:,:,:) :: flux_rsz_vf, flux_src_rsz_vf + $:GPU_DECLARE(create='[flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf]') !> @} - !> The cell-boundary values of the geometrical source flux that are computed - !! through the chosen Riemann problem solver by using the left and right - !! states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. + !> The cell-boundary values of the geometrical source flux that are computed through the chosen Riemann problem solver by using + !! the left and right states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. !> @{ - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf !< - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf !< - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf !< - $:GPU_DECLARE(create='[flux_gsrc_rsx_vf,flux_gsrc_rsy_vf,flux_gsrc_rsz_vf]') + real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsx_vf !< + real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsy_vf !< + real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsz_vf !< + $:GPU_DECLARE(create='[flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf]') !> @} ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as ! part of Riemann problem solution and is used to evaluate the source flux. - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsz_vf - $:GPU_DECLARE(create='[vel_src_rsx_vf,vel_src_rsy_vf,vel_src_rsz_vf]') + real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsx_vf + real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsy_vf + real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsz_vf + $:GPU_DECLARE(create='[vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf]') - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsz_vf - $:GPU_DECLARE(create='[mom_sp_rsx_vf,mom_sp_rsy_vf,mom_sp_rsz_vf]') + real(wp), allocatable, dimension(:,:,:,:) :: mom_sp_rsx_vf + real(wp), allocatable, dimension(:,:,:,:) :: mom_sp_rsy_vf + real(wp), allocatable, dimension(:,:,:,:) :: mom_sp_rsz_vf + $:GPU_DECLARE(create='[mom_sp_rsx_vf, mom_sp_rsy_vf, mom_sp_rsz_vf]') - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsz_vf - $:GPU_DECLARE(create='[Re_avg_rsx_vf,Re_avg_rsy_vf,Re_avg_rsz_vf]') + real(wp), allocatable, dimension(:,:,:,:) :: Re_avg_rsx_vf + real(wp), allocatable, dimension(:,:,:,:) :: Re_avg_rsy_vf + real(wp), allocatable, dimension(:,:,:,:) :: Re_avg_rsz_vf + $:GPU_DECLARE(create='[Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf]') !> @name Indical bounds in the s1-, s2- and s3-directions !> @{ @@ -95,273 +84,177 @@ module m_riemann_solvers type(int_bounds_info) :: isx, isy, isz !> @} - $:GPU_DECLARE(create='[is1,is2,is3,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 + 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 reference: - !! 1) s_hll_riemann_solver - !! 2) s_hllc_riemann_solver - !! 3) s_exact_riemann_solver - !! 4) s_hlld_riemann_solver - !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) - !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) - !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) - !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) - !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param q_prim_vf Cell-averaged primitive variables - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf - - type(scalar_field), allocatable, dimension(:), intent(INOUT) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(INOUT) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(IN) :: norm_dir - - type(int_bounds_info), intent(IN) :: ix, iy, iz + !> Dispatch to the subroutines that are utilized to compute the Riemann problem solution. For additional information please + !! reference: 1) s_hll_riemann_solver 2) s_hllc_riemann_solver 3) s_exact_riemann_solver 4) s_hlld_riemann_solver + !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) + !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) + !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the cell-average primitive variables + !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) + !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) + !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the cell-average primitive variables + !! @param q_prim_vf Cell-averaged primitive variables + !! @param flux_vf Intra-cell fluxes + !! @param flux_src_vf Intra-cell fluxes sources + !! @param flux_gsrc_vf Intra-cell geometric fluxes sources + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & + & qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz #:for NAME, NUM in [('hll', 1), ('hllc', 2), ('hlld', 4), ('lf', 5)] if (riemann_solver == ${NUM}$) then - call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) + call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & + & dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, & + & flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) end if #:endfor - end subroutine s_riemann_solver + !> Dispatch to the subroutines that are utilized to compute the viscous source fluxes for either Cartesian or cylindrical + !! geometries. For more information please refer to: 1) s_compute_cartesian_viscous_source_flux 2) + !! s_compute_cylindrical_viscous_source_flux + subroutine s_compute_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, dvelR_dy_vf, & + & dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) - !> Dispatch to the subroutines that are utilized to compute - !! the viscous source fluxes for either Cartesian or cylindrical geometries. - !! For more information please refer to: - !! 1) s_compute_cartesian_viscous_source_flux - !! 2) s_compute_cylindrical_viscous_source_flux - subroutine s_compute_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - - type(scalar_field), & - dimension(num_vels), & - intent(IN) :: velL_vf, velR_vf, & - dvelL_dx_vf, dvelR_dx_vf, & - dvelL_dy_vf, dvelR_dy_vf, & - dvelL_dz_vf, dvelR_dz_vf - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: flux_src_vf - - integer, intent(IN) :: norm_dir - - type(int_bounds_info), intent(IN) :: ix, iy, iz + type(scalar_field), dimension(num_vels), intent(in) :: velL_vf, velR_vf, dvelL_dx_vf, dvelR_dx_vf, dvelL_dy_vf, & + & dvelR_dy_vf, dvelL_dz_vf, dvelR_dz_vf + + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz if (grid_geometry == 3) then - call s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) + call s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & + & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) else - call s_compute_cartesian_viscous_source_flux(dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir) + 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, norm_dir) end if end subroutine s_compute_viscous_source_flux - !> @brief Computes intercell fluxes using the Harten-Lax-van Leer (HLL) approximate Riemann solver. - subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - + subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + & dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, & + & norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf + 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 + 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(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_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 + 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) :: 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 :: i, j, k, l, q !< Generic loop iterators ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - norm_dir, ix, iy, iz) + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_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) + call s_initialize_riemann_solver(flux_src_vf, norm_dir) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - 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]') + $: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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -463,10 +356,8 @@ contains $: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) + 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) @@ -526,7 +417,7 @@ contains 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 - elseif (mhd .and. relativity) then + 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 @@ -552,15 +443,17 @@ contains E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - elseif (mhd .and. .not. relativity) then + 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 - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R & + & + pres_mag%R ! includes magnetic energy H_L = (E_L + pres_L - pres_mag%L)/rho_L - H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + H_R = (E_R + pres_R - pres_mag%R) & + & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 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 @@ -588,7 +481,7 @@ contains tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) ! Elastic contribution to energy if G large enough - !TODO take out if statement if stable without + ! 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) @@ -602,7 +495,7 @@ contains end if ! elastic energy update - !if ( hyperelasticity ) then + ! if ( hyperelasticity ) then ! G_L = 0._wp ! G_R = 0._wp ! @@ -631,21 +524,21 @@ contains ! xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) ! end do ! end if - !end if + ! end if @:compute_average_state() - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L, qv_L) + 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) + 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) + 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) @@ -666,24 +559,20 @@ contains if (mhd) then s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) - elseif (hypoelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L)) + else if (hypoelasticity) then + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & + & /rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & + & /rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & + & /rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & + & /rho_L)) else if (hyperelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + 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) @@ -695,42 +584,33 @@ contains 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)))) - elseif (wave_speeds == 2) 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)))) + 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 == 2) 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 - 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))))) + 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)) + 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)) + 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)) ! Low Mach correction if (low_Mach == 1) then @@ -743,22 +623,17 @@ contains if (.not. relativity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*alpha_rho_R(i)*vel_R(norm_dir) & - - s_P*alpha_rho_L(i)*vel_L(norm_dir) & - + s_M*s_P*(alpha_rho_L(i) & - - alpha_rho_R(i))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i) & + & *vel_L(norm_dir) + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) end do - elseif (relativity) then + else if (relativity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) & - - s_P*Ga%L*alpha_rho_L(i)*vel_L(norm_dir) & - + s_M*s_P*(Ga%L*alpha_rho_L(i) & - - Ga%R*alpha_rho_R(i))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i) & + & *vel_L(norm_dir) + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i))) & + & /(s_M - s_P) end do end if @@ -768,76 +643,52 @@ contains 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_rs${XYZ}$_vf(j, k, l, contxe + i) = & - (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) & - - B%R(i)*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & - - B%L(i)*B%L(norm_dir) & - + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) & + & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & + & - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) end do - elseif (mhd .and. relativity) then + 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_rs${XYZ}$_vf(j, k, l, contxe + i) = & - (s_M*(cm%R(i)*vel_R(norm_dir) & - - b4%R(i)/Ga%R*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(i)*vel_L(norm_dir) & - - b4%L(i)/Ga%L*B%L(norm_dir) & - + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(i) - cm%R(i))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) & + & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) & + & - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) end do - elseif (bubbles_euler) then + else if (bubbles_euler) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do else if (hypoelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_R & - - tau_e_R(dir_idx_tau(i))) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_L & - - tau_e_L(dir_idx_tau(i))) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & + & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & + & *pres_L - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) end do else $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_R) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_L) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do end if @@ -845,27 +696,25 @@ contains 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_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & + & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + & - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir) & + & *(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) #:endif - elseif (mhd .and. relativity) then + else if (mhd .and. relativity) then ! energy flux = m_${XYZ}$ - mass flux ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) else if (bubbles_euler) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + & - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M & + & - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then flux_tau_L = 0._wp; flux_tau_R = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -873,44 +722,34 @@ contains flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & - + s_M*s_P*(E_L - E_R))/(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R)) & + & /(s_M - s_P) else - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & + & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R_rms - vel_L_rms)/2._wp end if ! Elastic Stresses if (hypoelasticity) then - do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *tau_e_R(i)) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *tau_e_L(i)) & - + s_M*s_P*(rho_L*tau_e_L(i) & - - rho_R*tau_e_R(i))) & - /(s_M - s_P) + do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow + flux_rs${XYZ}$_vf(j, k, l, & + & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & + & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & + & - rho_R*tau_e_R(i)))/(s_M - s_P) end do end if ! Advection $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (qL_prim_rs${XYZ}$_vf(j, k, l, i) & - - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) & - *s_M*s_P/(s_M - s_P) - flux_src_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, i) = (qL_prim_rs${XYZ}$_vf(j, k, l, i) - qR_prim_rs${XYZ}$_vf(j + 1, & + & k, l, i))*s_M*s_P/(s_M - s_P) + flux_src_rs${XYZ}$_vf(j, k, l, i) = (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) end do if (bubbles_euler) then @@ -926,10 +765,9 @@ contains Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - flux_rs${XYZ}$_vf(j, k, l, i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) & - - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - + s_M*s_P*(Y_L*rho_L - Y_R*rho_R)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if @@ -940,9 +778,10 @@ contains ! B_z flux = v_x * B_z - v_z * Bx0 $:GPU_LOOP(parallelism='[seq]') do i = 0, 1 - flux_rsx_vf(j, k, l, B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & - - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) & - + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) + flux_rsx_vf(j, k, l, & + & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & + & - B%R(2 + i)))/(s_M - s_P) end do else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) @@ -950,19 +789,26 @@ contains ! 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_rs${XYZ}$_vf(j, k, l, B_idx%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) + flux_rs${XYZ}$_vf(j, k, l, & + & B_idx%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_rs${XYZ}$_vf(j, k, l, B_idx%beg + norm_dir - 1) = flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + norm_dir - 1) + & - (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, psi_idx) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx))/(s_M - s_P) - - flux_rs${XYZ}$_vf(j, k, l, psi_idx) = (hyper_cleaning_speed**2*(s_M*B%R(norm_dir) - s_P*B%L(norm_dir)) + s_M*s_P*(qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, psi_idx)))/(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + norm_dir - 1) = flux_rs${XYZ}$_vf(j, k, l, & + & B_idx%beg + norm_dir - 1) + (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & psi_idx) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx))/(s_M - s_P) + + flux_rs${XYZ}$_vf(j, k, l, & + & psi_idx) = (hyper_cleaning_speed**2*(s_M*B%R(norm_dir) & + & - s_P*B%L(norm_dir)) + s_M*s_P*(qL_prim_rs${XYZ}$_vf(j, k, l, & + & psi_idx) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, psi_idx)))/(s_M - s_P) else - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + norm_dir - 1) = 0._wp ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero + flux_rs${XYZ}$_vf(j, k, l, & + & B_idx%beg + norm_dir - 1) & + & = 0._wp ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero end if end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -970,15 +816,14 @@ contains #:if (NORM_DIR == 2) if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux + ! Substituting the advective flux into the inviscid geometrical source flux $:GPU_LOOP(parallelism='[seq]') do i = 1, E_idx flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) & - - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_rs${XYZ}$_vf(j, k, l, & + & contxe + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -988,10 +833,8 @@ contains if (cyl_coord .and. hypoelasticity) then ! += tau_sigmasigma using HLL - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) + & - (s_M*tau_e_R(4) - s_P*tau_e_L(4)) & - /(s_M - s_P) + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) $:GPU_LOOP(parallelism='[seq]') do i = strxb, strxe @@ -999,165 +842,127 @@ contains end do end if #:endif - end do end do end do $:END_GPU_PARALLEL_LOOP() end if - #:endfor if (viscous .or. dummy) then if (weno_Re_flux) then - - call s_compute_viscous_source_flux( & - qL_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - qR_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) + call s_compute_viscous_source_flux(qL_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & + & qR_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & + & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) else - call s_compute_viscous_source_flux( & - q_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - q_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) + call s_compute_viscous_source_flux(q_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & + & q_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & + & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) end if end if - call s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir) - + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) end subroutine s_hll_riemann_solver - !> @brief Computes intercell fluxes using the Lax-Friedrichs (LF) approximate Riemann solver. - subroutine s_lf_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - + subroutine s_lf_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + & dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, & + & norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf + type(scalar_field), 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 + 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) :: 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 - real(wp), dimension(num_dims, num_dims) :: vel_grad_L, vel_grad_R !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + 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 + real(wp), dimension(num_dims, num_dims) :: vel_grad_L, & + & vel_grad_R !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. #: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 + 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) :: 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. + 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, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - norm_dir, ix, iy, iz) + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_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) + call s_initialize_riemann_solver(flux_src_vf, norm_dir) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - 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]') + $: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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -1259,10 +1064,8 @@ contains $: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) + 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) @@ -1323,7 +1126,7 @@ contains 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 - elseif (mhd .and. relativity) then + 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) @@ -1348,13 +1151,15 @@ contains 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 - elseif (mhd .and. .not. relativity) then + 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 - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R & + & + pres_mag%R ! includes magnetic energy H_L = (E_L + pres_L - pres_mag%L)/rho_L - H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + H_R = (E_R + pres_R - pres_mag%R) & + & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 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 @@ -1381,7 +1186,7 @@ contains tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) ! Elastic contribution to energy if G large enough - !TODO take out if statement if stable without + ! 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) @@ -1394,11 +1199,11 @@ contains 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_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) + 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) @@ -1433,22 +1238,17 @@ contains if (.not. relativity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*alpha_rho_R(i)*vel_R(norm_dir) & - - s_P*alpha_rho_L(i)*vel_L(norm_dir) & - + s_M*s_P*(alpha_rho_L(i) & - - alpha_rho_R(i))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i) & + & *vel_L(norm_dir) + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) end do - elseif (relativity) then + else if (relativity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) & - - s_P*Ga%L*alpha_rho_L(i)*vel_L(norm_dir) & - + s_M*s_P*(Ga%L*alpha_rho_L(i) & - - Ga%R*alpha_rho_R(i))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i) & + & *vel_L(norm_dir) + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i))) & + & /(s_M - s_P) end do end if @@ -1458,76 +1258,52 @@ contains 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_rs${XYZ}$_vf(j, k, l, contxe + i) = & - (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) & - - B%R(i)*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & - - B%L(i)*B%L(norm_dir) & - + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) & + & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & + & - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) end do - elseif (mhd .and. relativity) then + 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_rs${XYZ}$_vf(j, k, l, contxe + i) = & - (s_M*(cm%R(i)*vel_R(norm_dir) & - - b4%R(i)/Ga%R*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(i)*vel_L(norm_dir) & - - b4%L(i)/Ga%L*B%L(norm_dir) & - + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(i) - cm%R(i))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) & + & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) & + & - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) end do - elseif (bubbles_euler) then + else if (bubbles_euler) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do else if (hypoelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_R & - - tau_e_R(dir_idx_tau(i))) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_L & - - tau_e_L(dir_idx_tau(i))) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & + & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & + & *pres_L - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) end do else $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_R) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_L) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do end if @@ -1535,27 +1311,25 @@ contains 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_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & + & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + & - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir) & + & *(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) #:endif - elseif (mhd .and. relativity) then + else if (mhd .and. relativity) then ! energy flux = m_${XYZ}$ - mass flux ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) else if (bubbles_euler) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + & - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M & + & - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then flux_tau_L = 0._wp; flux_tau_R = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -1563,44 +1337,34 @@ contains flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & - + s_M*s_P*(E_L - E_R))/(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R)) & + & /(s_M - s_P) else - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & + & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R_rms - vel_L_rms)/2._wp end if ! Elastic Stresses if (hypoelasticity) then - do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *tau_e_R(i)) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *tau_e_L(i)) & - + s_M*s_P*(rho_L*tau_e_L(i) & - - rho_R*tau_e_R(i))) & - /(s_M - s_P) + do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow + flux_rs${XYZ}$_vf(j, k, l, & + & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & + & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & + & - rho_R*tau_e_R(i)))/(s_M - s_P) end do end if ! Advection $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (qL_prim_rs${XYZ}$_vf(j, k, l, i) & - - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) & - *s_M*s_P/(s_M - s_P) - flux_src_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, i) = (qL_prim_rs${XYZ}$_vf(j, k, l, i) - qR_prim_rs${XYZ}$_vf(j + 1, & + & k, l, i))*s_M*s_P/(s_M - s_P) + flux_src_rs${XYZ}$_vf(j, k, l, i) = (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) end do if (bubbles_euler) then @@ -1616,10 +1380,9 @@ contains Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - flux_rs${XYZ}$_vf(j, k, l, i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) & - - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - + s_M*s_P*(Y_L*rho_L - Y_R*rho_R)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if @@ -1630,9 +1393,10 @@ contains ! B_z flux = v_x * B_z - v_z * Bx0 $:GPU_LOOP(parallelism='[seq]') do i = 0, 1 - flux_rsx_vf(j, k, l, B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & - - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) & - + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) + flux_rsx_vf(j, k, l, & + & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & + & - B%R(2 + i)))/(s_M - s_P) end do else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) @@ -1640,10 +1404,11 @@ contains ! 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_rs${XYZ}$_vf(j, k, l, B_idx%beg + i) = (1 - dir_flg(i + 1))*( & - s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & - s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, & + & B_idx%beg + i) = (1 - dir_flg(i + 1))*(s_M*(vel_R(dir_idx(1))*B%R(i & + & + 1) - vel_R(i + 1)*B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) & + & - vel_L(i + 1)*B%L(norm_dir)) + s_M*s_P*(B%L(i + 1) - B%R(i + 1))) & + & /(s_M - s_P) end do end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -1651,15 +1416,14 @@ contains #:if (NORM_DIR == 2) if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux + ! Substituting the advective flux into the inviscid geometrical source flux $:GPU_LOOP(parallelism='[seq]') do i = 1, E_idx flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) & - - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_rs${XYZ}$_vf(j, k, l, & + & contxe + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -1669,10 +1433,8 @@ contains if (cyl_coord .and. hypoelasticity) then ! += tau_sigmasigma using HLL - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) + & - (s_M*tau_e_R(4) - s_P*tau_e_L(4)) & - /(s_M - s_P) + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) $:GPU_LOOP(parallelism='[seq]') do i = strxb, strxe @@ -1685,11 +1447,11 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - #:endfor if (viscous .or. dummy) 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]') + $: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 @@ -1745,10 +1507,8 @@ contains $: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) + 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) @@ -1756,231 +1516,266 @@ contains end do if (shear_stress) then - $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_grad_L(i, 1) = (dqL_prim_dx_vf(momxb + i - 1)%sf(j, k, l)/Re_L(1)) - vel_grad_R(i, 1) = (dqR_prim_dx_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))/Re_R(1)) + vel_grad_R(i, 1) = (dqR_prim_dx_vf(momxb + 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(momxb + i - 1)%sf(j, k, l)/Re_L(1)) - vel_grad_R(i, 2) = (dqR_prim_dy_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))/Re_R(1)) + vel_grad_R(i, 2) = (dqR_prim_dy_vf(momxb + 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(momxb + i - 1)%sf(j, k, l)/Re_L(1)) - vel_grad_R(i, 3) = (dqR_prim_dz_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))/Re_R(1)) + vel_grad_R(i, 3) = (dqR_prim_dz_vf(momxb + 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + flux_src_vf(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + i - 1)%sf(j, k, l)/Re_L(2)) - vel_grad_R(i, 1) = (dqR_prim_dx_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + vel_grad_R(i, 1) = (dqR_prim_dx_vf(momxb + 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(momxb + i - 1)%sf(j, k, l)/Re_L(2)) - vel_grad_R(i, 2) = (dqR_prim_dy_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + vel_grad_R(i, 2) = (dqR_prim_dy_vf(momxb + 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(momxb + i - 1)%sf(j, k, l)/Re_L(2)) - vel_grad_R(i, 3) = (dqR_prim_dz_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + vel_grad_R(i, 3) = (dqR_prim_dz_vf(momxb + 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, 1)*vel_L(1) + vel_grad_R(1, 1)*vel_R(1)) + flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & + & 1) + vel_grad_R(1, 1)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, 2)*vel_L(1) + vel_grad_R(2, 2)*vel_R(1)) + flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & + & 2) + vel_grad_R(2, 2)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(1) + vel_grad_R(3, 3)*vel_R(1)) + flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, 2)*vel_L(2) + vel_grad_R(2, 2)*vel_R(2)) + flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(2) + vel_grad_R(3, 3)*vel_R(2)) + flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) + flux_src_vf(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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) - + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) end subroutine s_lf_riemann_solver - - !> This procedure is the implementation of the Harten, Lax, - !! van Leer, and contact (HLLC) approximate Riemann solver, - !! see Toro (1999) and Johnsen (2007). The viscous and the - !! surface tension effects have been included by modifying - !! the exact Riemann solver of Perigaud and Saurel (2005). - !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) - !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) - !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) - !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) - !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param q_prim_vf Cell-averaged primitive variables - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + !> This procedure is the implementation of the Harten, Lax, van Leer, and contact (HLLC) approximate Riemann solver, see Toro + !! (1999) and Johnsen (2007). The viscous and the surface tension effects have been included by modifying the exact Riemann + !! solver of Perigaud and Saurel (2005). + !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) + !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) + !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the cell-average primitive variables + !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) + !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) + !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the cell-average primitive variables + !! @param q_prim_vf Cell-averaged primitive variables + !! @param flux_vf Intra-cell fluxes + !! @param flux_src_vf Intra-cell fluxes sources + !! @param flux_gsrc_vf Intra-cell geometric fluxes sources + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & + & dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, & + & flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf + 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 + 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 @@ -1989,7 +1784,7 @@ contains #: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 + real(wp), dimension(num_dims) :: vel_L, vel_R #:endif real(wp) :: rho_L, rho_R @@ -2003,30 +1798,28 @@ contains 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) :: 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_M, xi_P - real(wp) :: xi_MP, xi_PP + 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_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 @@ -2039,13 +1832,11 @@ contains 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) :: 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 @@ -2053,46 +1844,42 @@ contains 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 + 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, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - norm_dir, ix, iy, iz) + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_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) + call s_initialize_riemann_solver(flux_src_vf, norm_dir) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (norm_dir == ${NORM_DIR}$) then - ! 6-EQUATION MODEL WITH HLLC if (model_eqns == 3) then - !ME3 - $: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_MP, xi_PP]') + ! ME3 + $: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_MP, xi_PP]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%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 @@ -2128,21 +1915,25 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, & + & E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, & + & k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, & + & E_idx + i)/max(alpha_L_sum, sgm_eps) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -2171,10 +1962,8 @@ contains 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_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res_gs(i, q) & - + Re_L(i) - Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res_gs(i, q) & - + Re_R(i) + Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res_gs(i, q) + Re_L(i) + Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + 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) @@ -2219,7 +2008,7 @@ contains xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) end do - G_L = 0._wp; G_R = 0._wp; + G_L = 0._wp; G_R = 0._wp; $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids ! Mixture left and right shear modulus @@ -2243,16 +2032,16 @@ contains @: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_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) + 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) + 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]') @@ -2269,44 +2058,41 @@ contains ! COMPUTING THE DIRECT WAVE SPEEDS if (wave_speeds == 1) then if (elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1)))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1)))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1)))/rho_L)) - s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + & - tau_e_L(dir_idx_tau(1)) + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) + s_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)))) - + s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & + & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L & + & - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) end if - elseif (wave_speeds == 2) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) + else if (wave_speeds == 2) 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 - 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))))) + 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)) + 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. @@ -2328,18 +2114,16 @@ contains 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))))) + 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)) + 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))) + 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 @@ -2352,40 +2136,41 @@ contains ! MASS FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! 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_rs${XYZ}$_vf(j, k, l, contxe + 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 + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + 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_rs${XYZ}$_vf(j, k, l, E_idx) = (E_star + p_Star)*vel_K_Star & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S + flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_star + p_Star)*vel_K_Star + (s_M/s_L)*(s_P/s_R)*pcorr*s_S ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux if (elasticity) then - flux_ene_e = 0._wp; + flux_ene_e = 0._wp; $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims ! MOMENTUM ELASTIC FLUX. - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) & - - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & + & contxe + 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)))))) + 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_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e end if @@ -2393,34 +2178,38 @@ contains ! VOLUME FRACTION FLUX. $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*s_S + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*s_S + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S end do ! SOURCE TERM FOR VOLUME FRACTION ADVECTION FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & - xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_MP*(xi_L - 1) + 1) - vel_L(dir_idx(i)))) + & - xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_PP*(xi_R - 1) + 1) - vel_R(dir_idx(i)))) + vel_src_rs${XYZ}$_vf(j, k, l, & + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & + & *(s_S*(xi_MP*(xi_L - 1) + 1) - vel_L(dir_idx(i)))) & + & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_PP*(xi_R - 1) & + & + 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_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & - ((xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1))* & - (gammas(i)*p_K_Star + pi_infs(i)) + & - (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1))* & - qvs(i))*vel_K_Star & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) + p_K_Star = xi_M*(xi_MP*((pres_L + pi_infs(i)/(1._wp + gammas(i)))*xi_L**(1._wp/gammas(i) & + & + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_L) + pres_L) & + & + xi_P*(xi_PP*((pres_R + pi_infs(i)/(1._wp + gammas(i))) & + & *xi_R**(1._wp/gammas(i) + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_R) & + & + pres_R) + + flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = ((xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i + advxb - 1))*(gammas(i)*p_K_Star + pi_infs(i)) & + & + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i + contxb - 1))*qvs(i))*vel_K_Star + (s_M/s_L)*(s_P/s_R) & + & *pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) end do flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) @@ -2429,9 +2218,10 @@ contains if (hypoelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, strxe - strxb + 1 - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(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)) + flux_rs${XYZ}$_vf(j, k, l, & + & strxb - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & + & - rho_L*vel_L(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 @@ -2439,25 +2229,23 @@ contains if (hyperelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - - rho_L*vel_L(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)) + flux_rs${XYZ}$_vf(j, k, l, & + & xibeg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & + & - rho_L*vel_L(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_rs${XYZ}$_vf(j, k, l, c_idx) = & - (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S + flux_rs${XYZ}$_vf(j, k, l, c_idx) = (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & c_idx) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S end if ! Geometrical source flux for cylindrical coordinates #:if (NORM_DIR == 2) if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux + ! Substituting the advective flux into the inviscid geometrical source flux $:GPU_LOOP(parallelism='[seq]') do i = 1, E_idx flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) @@ -2467,8 +2255,8 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & momxb - 1 + dir_idx(1)) - p_Star ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -2482,25 +2270,28 @@ contains do i = 1, sys_size flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & momxb - 1 + dir_idx(1)) - p_Star flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif - end do end do end do $:END_GPU_PARALLEL_LOOP() - - elseif (model_eqns == 4) then - !ME4 - $: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_MP, xi_PP]') + else if (model_eqns == 4) then + ! ME4 + $: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_MP, xi_PP]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%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 @@ -2556,48 +2347,41 @@ contains @: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_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) + 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) + 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 == 1) then s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) + 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 == 2) 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 - 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))))) + 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)) + 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. @@ -2616,60 +2400,48 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*alpha_rho_L(i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*alpha_rho_R(i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, & + & i) = xi_M*alpha_rho_L(i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*alpha_rho_R(i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Momentum flux. ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(i)) + & - s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & - dir_flg(dir_idx(i))*pres_L) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(i)) + & - s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & - dir_flg(dir_idx(i))*pres_R) + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_L) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_R) end do if (bubbles_euler) then ! Put p_tilde in $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) + & - xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & - + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) + xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & + & + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) end do end if flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0._wp $:GPU_LOOP(parallelism='[seq]') - do i = alf_idx, alf_idx !only advect the void fraction - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + do i = alf_idx, alf_idx ! only advect the void fraction + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp - !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp + ! IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp end do flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) @@ -2678,11 +2450,10 @@ contains if (bubbles_euler) then $:GPU_LOOP(parallelism='[seq]') do i = bubxb, bubxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do end if @@ -2696,17 +2467,13 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -2720,17 +2487,13 @@ contains do i = 1, sys_size flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -2738,13 +2501,16 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - - elseif (model_eqns == 2 .and. bubbles_euler) then - $: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_MP, xi_PP, nbub_L, nbub_R, PbwR3Lbar, PbwR3Rbar, R3Lbar, R3Rbar, R3V2Lbar, R3V2Rbar]') + else if (model_eqns == 2 .and. bubbles_euler) then + $: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_MP, xi_PP, nbub_L, nbub_R, PbwR3Lbar, PbwR3Rbar, & + & R3Lbar, R3Rbar, R3V2Lbar, R3V2Rbar]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%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 @@ -2815,15 +2581,14 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 1, Re_size(i) - Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res_gs(i, q) & - + Re_L(i) - Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res_gs(i, q) & - + Re_R(i) + Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res_gs(i, & + & q) + Re_L(i) + Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, & + & q)))/Res_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 @@ -2868,7 +2633,7 @@ contains nbub_R = (3._wp/(4._wp*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R end if else - !nb stored in 0th moment of first R0 bin in variable conversion module + ! nb stored in 0th moment of first R0 bin in variable conversion module nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, bubxb) nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, bubxb) end if @@ -2924,19 +2689,18 @@ contains 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_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) + 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) + 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]') @@ -2954,32 +2718,25 @@ contains s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) + 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 == 2) 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 - 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))))) + 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)) + 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. @@ -3005,11 +2762,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do if (bubbles_euler .and. (num_fluids > 1)) then @@ -3026,71 +2781,54 @@ contains 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) + 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) + 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_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(i)) + & - s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & - dir_flg(dir_idx(i))*(pres_L)) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(i)) + & - s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & - dir_flg(dir_idx(i))*(pres_R)) & - + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) & + & + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr end do ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - xi_M*(vel_L(dir_idx(1))*(E_L + pres_L) + & - 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 + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = 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 = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & - xi_M*(vel_L(dir_idx(i)) + & - dir_flg(dir_idx(i))* & - s_M*(xi_L - 1._wp)) & - + xi_P*(vel_R(dir_idx(i)) + & - dir_flg(dir_idx(i))* & - s_P*(xi_R - 1._wp)) - - !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp + vel_src_rs${XYZ}$_vf(j, k, l, & + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L & + & - 1._wp)) + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R & + & - 1._wp)) + + ! IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp end do flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) @@ -3098,27 +2836,22 @@ contains ! Add advection flux for bubble variables $:GPU_LOOP(parallelism='[seq]') do i = bubxb, bubxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do if (qbmm) then - flux_rs${XYZ}$_vf(j, k, l, bubxb) = & - xi_M*nbub_L & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, & + & bubxb) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if if (adv_n) then - flux_rs${XYZ}$_vf(j, k, l, n_idx) = & - xi_M*nbub_L & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, & + & n_idx) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if ! Geometrical source flux for cylindrical coordinates @@ -3130,17 +2863,13 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -3155,19 +2884,14 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if #:endif end do @@ -3176,11 +2900,16 @@ contains $:END_GPU_PARALLEL_LOOP() else ! 5-EQUATION MODEL WITH HLLC - $: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, 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]') + $: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, 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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%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 @@ -3211,17 +2940,21 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, & + & E_idx + i)), 1._wp) qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, & + & k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, & + & E_idx + i)/max(alpha_L_sum, sgm_eps) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -3250,10 +2983,8 @@ contains $: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) + 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) @@ -3383,16 +3114,16 @@ contains @: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_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) + 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) + 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 @@ -3411,44 +3142,41 @@ contains if (wave_speeds == 1) then if (elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1)))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1)))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1)))/rho_L)) - s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + & - tau_e_L(dir_idx_tau(1)) + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) + s_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)))) - + s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & + & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L & + & - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) end if - elseif (wave_speeds == 2) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) + else if (wave_speeds == 2) 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 - 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))))) + 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)) + 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. @@ -3476,45 +3204,33 @@ contains ! MASS FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! 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_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(i)) + & - s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & - dir_flg(dir_idx(i))*(pres_L)) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(i)) + & - s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & - dir_flg(dir_idx(i))*(pres_R)) & - + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + flux_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) & + & + (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_rs${XYZ}$_vf(j, k, l, E_idx) = & - 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 + flux_rs${XYZ}$_vf(j, k, l, & + & E_idx) = 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 ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux if (elasticity) then @@ -3522,15 +3238,15 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims ! MOMENTUM ELASTIC FLUX. - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) & - - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & + & contxe + 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)))))) + 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_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e end if @@ -3539,52 +3255,46 @@ contains if (hypoelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, strxe - strxb + 1 - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(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)) + flux_rs${XYZ}$_vf(j, k, l, & + & strxb - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & + & - rho_L*vel_L(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 = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! VOLUME FRACTION SOURCE FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & - xi_M*(vel_L(dir_idx(i)) + & - dir_flg(dir_idx(i))* & - s_M*(xi_L - 1._wp)) & - + xi_P*(vel_R(dir_idx(i)) + & - dir_flg(dir_idx(i))* & - s_P*(xi_R - 1._wp)) + vel_src_rs${XYZ}$_vf(j, k, l, & + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L & + & - 1._wp)) + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R & + & - 1._wp)) end do ! COLOR FUNCTION FLUX if (surface_tension) then - flux_rs${XYZ}$_vf(j, k, l, c_idx) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, c_idx) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & c_idx)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & c_idx)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if ! REFERENCE MAP FLUX. if (hyperelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - - rho_L*vel_L(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)) + flux_rs${XYZ}$_vf(j, k, l, & + & xibeg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & + & - rho_L*vel_L(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 @@ -3596,8 +3306,9 @@ contains Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*rho_L*Y_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*rho_R*Y_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + flux_rs${XYZ}$_vf(j, k, l, & + & i) = xi_M*rho_L*Y_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*rho_R*Y_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0.0_wp end do end if @@ -3605,23 +3316,19 @@ contains ! Geometrical source flux for cylindrical coordinates #:if (NORM_DIR == 2) if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux + ! Substituting the advective flux into the inviscid geometrical source flux $:GPU_LOOP(parallelism='[seq]') do i = 1, E_idx flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -3636,22 +3343,16 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, & + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if #:endif - end do end do end do @@ -3663,71 +3364,44 @@ contains if (viscous .or. dummy) then if (weno_Re_flux) then - call s_compute_viscous_source_flux( & - qL_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - qR_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) + call s_compute_viscous_source_flux(qL_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & + & qR_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & + & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) else - call s_compute_viscous_source_flux( & - q_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - q_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) + call s_compute_viscous_source_flux(q_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & + & q_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & + & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) end if end if if (surface_tension) then - call s_compute_capillary_source_flux( & - vel_src_rsx_vf, & - vel_src_rsy_vf, & - vel_src_rsz_vf, & - flux_src_vf, & - norm_dir, isx, isy, isz) + call s_compute_capillary_source_flux(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf, flux_src_vf, norm_dir, isx, isy, & + & isz) end if - call s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir) - + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) end subroutine s_hllc_riemann_solver + !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: 1 entropy wave, 2 Alfven waves, 2 fast magnetosonic waves. + subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & + & dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, & + & flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: - !! 1 entropy wave, 2 Alfvén waves, 2 fast magnetosonic waves. - subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & - dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & - dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - qR_prim_vf, & - q_prim_vf, & - flux_vf, flux_src_vf, flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_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 + 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 @@ -3736,17 +3410,15 @@ contains 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) :: 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 + 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) :: 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 @@ -3757,26 +3429,25 @@ contains 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 - integer :: i, j, k, l - - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, dqL_prim_dz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, dqR_prim_dz_vf, & - norm_dir, ix, iy, iz) + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_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) + call s_initialize_riemann_solver(flux_src_vf, norm_dir) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] 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]') + $: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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end - ! (1) Extract the left/right primitive states do i = 1, contxe alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) @@ -3803,15 +3474,17 @@ contains ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic if (mhd) then if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated - B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1)] - B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1)] + B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, & + & B_idx%beg + 1)] + B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & B_idx%beg + 1)] else ! 2D/3D: Bx, By, Bz as variables - B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), & - qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1), & - qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] + B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), qL_prim_rs${XYZ}$_vf(j, k, & + & l, B_idx%beg + dir_idx(2) - 1), qL_prim_rs${XYZ}$_vf(j, k, l, & + & B_idx%beg + dir_idx(3) - 1)] B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] + & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & + & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] end if end if @@ -3836,11 +3509,14 @@ contains E%L = gamma%L*pres%L + pi_inf%L + 0.5_wp*rho%L*vel_rms%L + qv%L + pres_mag%L E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L - H_no_mag%R = (E%R + pres%R - pres_mag%R)/rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + H_no_mag%R = (E%R + pres%R - pres_mag%R) & + & /rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) ! (2) Compute fast wave speeds - call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, 0._wp, c%L, 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_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) @@ -3851,9 +3527,8 @@ contains 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)) + 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) @@ -3883,28 +3558,34 @@ contains ! Compute the star flux using HLL relation F_starL = F_L + s_L*(U_starL - U_L) F_starR = F_R + s_R*(U_starR - U_R) - ! Compute the rotational (Alfvén) speeds + ! Compute the rotational (Alfven) speeds s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) - ! Compute the double–star states [Miyoshi Eqns. (59)-(62)] + ! Compute the double-star states [Miyoshi Eqns. (59)-(62)] sqrt_rhoL_star = sqrt(rhoL_star); sqrt_rhoR_star = sqrt(rhoR_star) vL_star = vel%L(2); wL_star = vel%L(3) vR_star = vel%R(2); wR_star = vel%R(3) - ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] + ! (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 + 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] + 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] ! (11) Choose HLLD flux based on wave-speed regions if (0.0_wp <= s_L) then @@ -3952,15 +3633,11 @@ contains end if #:endfor - call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & - norm_dir) + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) end subroutine s_hlld_riemann_solver - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_riemann_solvers_module - ! Allocating the variables that will be utilized to formulate the ! left, right, and average states of the Riemann problem, as well ! the Riemann problem solution @@ -3983,34 +3660,24 @@ contains Res_gs(i, j) = fluid_pp(Re_idx(i, j))%Re(i) end do end do - $:GPU_UPDATE(device='[Res_gs,Re_idx,Re_size]') + $:GPU_UPDATE(device='[Res_gs, Re_idx, Re_size]') end if - $:GPU_ENTER_DATA(copyin='[is1,is2,is3,isx,isy,isz]') + $:GPU_ENTER_DATA(copyin='[is1, is2, is3, isx, isy, isz]') is1%beg = -1; is2%beg = 0; is3%beg = 0 is1%end = m; is2%end = n; is3%end = p - @:ALLOCATE(flux_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) + @:ALLOCATE(flux_rsx_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsx_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsx_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsx_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:num_vels)) if (qbmm) then @:ALLOCATE(mom_sp_rsx_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if (viscous) then - @:ALLOCATE(Re_avg_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) + @:ALLOCATE(Re_avg_rsx_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:2)) end if if (n == 0) return @@ -4018,27 +3685,17 @@ contains is1%beg = -1; is2%beg = 0; is3%beg = 0 is1%end = n; is2%end = m; is3%end = p - @:ALLOCATE(flux_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) + @:ALLOCATE(flux_rsy_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsy_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsy_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsy_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:num_vels)) if (qbmm) then @:ALLOCATE(mom_sp_rsy_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if (viscous) then - @:ALLOCATE(Re_avg_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) + @:ALLOCATE(Re_avg_rsy_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:2)) end if if (p == 0) return @@ -4046,82 +3703,56 @@ contains is1%beg = -1; is2%beg = 0; is3%beg = 0 is1%end = p; is2%end = n; is3%end = m - @:ALLOCATE(flux_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) + @:ALLOCATE(flux_rsz_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsz_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsz_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsz_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:num_vels)) if (qbmm) then @:ALLOCATE(mom_sp_rsz_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if (viscous) then - @:ALLOCATE(Re_avg_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) + @:ALLOCATE(Re_avg_rsz_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:2)) end if - end subroutine s_initialize_riemann_solvers_module - - !> The purpose of this subroutine is to populate the buffers - !! of the left and right Riemann states variables, depending - !! on the boundary conditions. - !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) - !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) - !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) - !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) - !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - subroutine s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - integer, intent(in) :: norm_dir + !> The purpose of this subroutine is to populate the buffers of the left and right Riemann states variables, depending on the + !! boundary conditions. + !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) + !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) + !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives + !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) + !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) + !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + subroutine s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_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, & + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + + integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: i, j, k, l !< Generic loop iterator + 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/) - elseif (norm_dir == 2) then + 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 @@ -4129,7 +3760,7 @@ contains dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) end if - $:GPU_UPDATE(device='[is1,is2,is3]') + $:GPU_UPDATE(device='[is1, is2, is3]') if (elasticity) then if (norm_dir == 1) then @@ -4143,20 +3774,18 @@ contains isx = ix; isy = iy; isz = iz ! for stuff in the same module - $:GPU_UPDATE(device='[isx,isy,isz]') + $:GPU_UPDATE(device='[isx, isy, isz]') ! for stuff in different modules - $:GPU_UPDATE(device='[dir_idx,dir_flg,dir_idx_tau]') + $: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 + 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) + qL_prim_rsx_vf(-1, k, l, i) = qR_prim_rsx_vf(0, k, l, i) end do end do end do @@ -4167,9 +3796,7 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do k = isy%beg, isy%end - - dqL_prim_dx_vf(i)%sf(-1, k, l) = & - dqR_prim_dx_vf(i)%sf(0, k, l) + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) end do end do end do @@ -4180,9 +3807,7 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do k = isy%beg, isy%end - - dqL_prim_dy_vf(i)%sf(-1, k, l) = & - dqR_prim_dy_vf(i)%sf(0, k, l) + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) end do end do end do @@ -4193,43 +3818,34 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do k = isy%beg, isy%end - - dqL_prim_dz_vf(i)%sf(-1, k, l) = & - dqR_prim_dz_vf(i)%sf(0, k, l) + 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 + 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) + 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 .or. dummy) then - $:GPU_PARALLEL_LOOP(collapse=3) do i = momxb, momxe do l = isz%beg, isz%end do k = isy%beg, isy%end - - dqR_prim_dx_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dx_vf(i)%sf(m, k, l) + 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 @@ -4240,9 +3856,7 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do k = isy%beg, isy%end - - dqR_prim_dy_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dy_vf(i)%sf(m, k, l) + 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 @@ -4253,45 +3867,36 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do k = isy%beg, isy%end - - dqR_prim_dz_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dz_vf(i)%sf(m, k, l) + 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 - elseif (norm_dir == 2) then - - if (bc_y%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + 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_rsy_vf(-1, k, l, i) = & - qR_prim_rsy_vf(0, k, l, i) + qL_prim_rsy_vf(-1, k, l, i) = qR_prim_rsy_vf(0, k, l, i) end do end do end do $:END_GPU_PARALLEL_LOOP() if (viscous .or. dummy) then - $:GPU_PARALLEL_LOOP(collapse=3) do i = momxb, momxe do l = isz%beg, isz%end do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, -1, l) = & - dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) end do end do end do @@ -4301,8 +3906,7 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, -1, l) = & - dqR_prim_dy_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) end do end do end do @@ -4313,39 +3917,33 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, -1, l) = & - dqR_prim_dz_vf(i)%sf(j, 0, l) + 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 + 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_rsy_vf(n + 1, k, l, i) = & - qL_prim_rsy_vf(n, k, l, i) + qR_prim_rsy_vf(n + 1, k, l, i) = qL_prim_rsy_vf(n, k, l, i) end do end do end do $:END_GPU_PARALLEL_LOOP() if (viscous .or. dummy) then - $:GPU_PARALLEL_LOOP(collapse=3) do i = momxb, momxe do l = isz%beg, isz%end do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dx_vf(i)%sf(j, n, l) + 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 @@ -4355,8 +3953,7 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dy_vf(i)%sf(j, n, l) + 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 @@ -4367,29 +3964,25 @@ contains do i = momxb, momxe do l = isz%beg, isz%end do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dz_vf(i)%sf(j, n, l) + 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 + 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 l = is3%beg, is3%end do k = is2%beg, is2%end - qL_prim_rsz_vf(-1, k, l, i) = & - qR_prim_rsz_vf(0, k, l, i) + qL_prim_rsz_vf(-1, k, l, i) = qR_prim_rsz_vf(0, k, l, i) end do end do end do @@ -4400,8 +3993,7 @@ contains do i = momxb, momxe do k = isy%beg, isy%end do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, k, -1) = & - dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) end do end do end do @@ -4410,8 +4002,7 @@ contains do i = momxb, momxe do k = isy%beg, isy%end do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, k, -1) = & - dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) end do end do end do @@ -4420,24 +4011,21 @@ contains do i = momxb, momxe do k = isy%beg, isy%end do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, k, -1) = & - dqR_prim_dz_vf(i)%sf(j, k, 0) + 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 + 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 l = is3%beg, is3%end do k = is2%beg, is2%end - qR_prim_rsz_vf(p + 1, k, l, i) = & - qL_prim_rsz_vf(p, k, l, i) + qR_prim_rsz_vf(p + 1, k, l, i) = qL_prim_rsz_vf(p, k, l, i) end do end do end do @@ -4448,8 +4036,7 @@ contains do i = momxb, momxe do k = isy%beg, isy%end do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dx_vf(i)%sf(j, k, p) + 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 @@ -4459,8 +4046,7 @@ contains do i = momxb, momxe do k = isy%beg, isy%end do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dy_vf(i)%sf(j, k, p) + 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 @@ -4470,45 +4056,29 @@ contains do i = momxb, momxe do k = isy%beg, isy%end do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dz_vf(i)%sf(j, k, p) + 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 - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures needed to configure the chosen Riemann - !! solver algorithm. - !! @param flux_src_vf Intra-cell fluxes sources - !! @param norm_dir Dir. splitting 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 + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures needed to configure the chosen Riemann solver algorithm. + !! @param flux_src_vf Intra-cell fluxes sources + !! @param norm_dir Dir. splitting 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) .or. dummy) then - $:GPU_PARALLEL_LOOP(collapse=4) do i = momxb, E_idx do l = is3%beg, is3%end @@ -4553,8 +4123,7 @@ contains end if ! Reshaping Inputted Data in y-direction - elseif (norm_dir == 2) then - + else if (norm_dir == 2) then if (viscous .or. (surface_tension) .or. dummy) then $:GPU_PARALLEL_LOOP(collapse=4) do i = momxb, E_idx @@ -4645,15 +4214,11 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - end if - end subroutine s_initialize_riemann_solver - - !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. - !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives - !! and cylindrical geometric factors, then updates `flux_src_vf`. - !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). + !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. Calculates Cartesian components of the + !! stress tensor using averaged velocity derivatives and cylindrical geometric factors, then updates `flux_src_vf`. Assumes + !! x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). !! @param[in] velL_vf Left boundary velocity (\f$v_x, v_y, v_z\f$) (num_dims scalar_field). !! @param[in] dvelL_dx_vf Left boundary \f$\partial v_i/\partial x\f$ (num_dims scalar_field). !! @param[in] dvelL_dy_vf Left boundary \f$\partial v_i/\partial y\f$ (num_dims scalar_field). @@ -4667,19 +4232,16 @@ contains !! @param[in] ix Global X-direction loop bounds (int_bounds_info). !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & - flux_src_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & + & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz ! Local variables #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -4688,31 +4250,35 @@ contains 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. - real(wp), dimension(3) :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + real(wp), & + & dimension(3) & + & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). #: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_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). - real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. - real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + real(wp), & + & dimension(num_dims) :: vel_src_int !!< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. + real(wp), & + & dimension(num_dims) & + & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). #: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. - 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. - - $: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]') + $: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]') 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 @@ -4723,17 +4289,17 @@ contains 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))) + 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))) + 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))) + 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 @@ -4794,7 +4360,8 @@ contains 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 + 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 @@ -4806,35 +4373,35 @@ contains #: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 + 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(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) + flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, & + & l) - stress_vector_shear(i_vel) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & + & l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) end do end if if (bulk_stress) then stress_normal_bulk = divergence_cyl/Re_b - flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk + flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, & + & l) - stress_normal_bulk flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk end if - end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_compute_cylindrical_viscous_source_flux - - !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. - !! Calculates averaged velocity gradients, gets Re and interface velocities, - !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. + !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. Calculates averaged velocity gradients, + !! gets Re and interface velocities, calls helpers for shear/bulk stress, then updates `flux_src_vf`. !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). @@ -4843,52 +4410,44 @@ contains !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). - 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, & - norm_dir) + 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, 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(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir + 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. + 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) :: 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. + 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. - - $: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]') + 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. + + $: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]') 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 @@ -4896,18 +4455,21 @@ contains 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))) + 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))) + 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))) + 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 @@ -4943,12 +4505,11 @@ contains call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = flux_src_vf(momxb + i_dim - 1)%sf(j_loop, & + & k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = flux_src_vf(E_idx)%sf(j_loop, k_loop, & + & l_loop) - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) end do end if @@ -4957,24 +4518,19 @@ contains call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = flux_src_vf(momxb + i_dim - 1)%sf(j_loop, & + & k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = flux_src_vf(E_idx)%sf(j_loop, k_loop, & + & l_loop) - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) end do end if - end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_compute_cartesian_viscous_source_flux - - !> @brief Calculates shear stress tensor components. - !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear + !> @brief Calculates shear stress tensor components. tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). !! @param[in] Re_shear Shear Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). @@ -4984,10 +4540,10 @@ contains ! 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(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(in) :: vel_grad_avg real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out #:endif real(wp), intent(in) :: Re_shear @@ -5003,16 +4559,12 @@ contains 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 + tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - (2.0_wp/3.0_wp)*divergence_v/Re_shear end if end do end do - end subroutine s_calculate_shear_stress_tensor - - !> @brief Calculates bulk stress tensor components (diagonal only). - !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. + !> @brief Calculates bulk stress tensor components (diagonal only). tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. !! @param[in] Re_bulk Bulk Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). @@ -5036,26 +4588,16 @@ contains do i_dim = 1, num_dims tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk end do - end subroutine s_calculate_bulk_stress_tensor - - !> Deallocation and/or disassociation procedures that are - !! needed to finalize the selected Riemann problem solver - !! @param flux_vf Intercell fluxes - !! @param flux_src_vf Intercell source fluxes - !! @param flux_gsrc_vf Intercell geometric source fluxes - !! @param norm_dir Dimensional splitting coordinate direction - 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 + !> Deallocation and/or disassociation procedures that are needed to finalize the selected Riemann problem solver + !! @param flux_vf Intercell fluxes + !! @param flux_src_vf Intercell source fluxes + !! @param flux_gsrc_vf Intercell geometric source fluxes + !! @param norm_dir Dimensional splitting coordinate direction + 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 @@ -5064,8 +4606,7 @@ contains do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) + flux_vf(i)%sf(k, j, l) = flux_rsy_vf(j, k, l, i) end do end do end do @@ -5078,8 +4619,7 @@ contains do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) + flux_gsrc_vf(i)%sf(k, j, l) = flux_gsrc_rsy_vf(j, k, l, i) end do end do end do @@ -5091,8 +4631,7 @@ contains do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end - flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, advxb) + flux_src_vf(advxb)%sf(k, j, l) = flux_src_rsy_vf(j, k, l, advxb) end do end do end do @@ -5104,25 +4643,21 @@ contains do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) + flux_src_vf(i)%sf(k, j, l) = flux_src_rsy_vf(j, k, l, i) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - end if ! Reshaping Outputted Data in z-direction - elseif (norm_dir == 3) then + 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_rsz_vf(j, k, l, i) + flux_vf(i)%sf(l, k, j) = flux_rsz_vf(j, k, l, i) end do end do end do @@ -5134,9 +4669,7 @@ contains do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end - - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) + flux_gsrc_vf(i)%sf(l, k, j) = flux_gsrc_rsz_vf(j, k, l, i) end do end do end do @@ -5148,8 +4681,7 @@ contains do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end - flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, advxb) + flux_src_vf(advxb)%sf(l, k, j) = flux_src_rsz_vf(j, k, l, advxb) end do end do end do @@ -5161,23 +4693,20 @@ contains do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) + flux_src_vf(i)%sf(l, k, j) = flux_src_rsz_vf(j, k, l, i) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - end if - elseif (norm_dir == 1) then + 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) + flux_vf(i)%sf(j, k, l) = flux_rsx_vf(j, k, l, i) end do end do end do @@ -5188,8 +4717,7 @@ contains do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end - flux_src_vf(advxb)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, advxb) + flux_src_vf(advxb)%sf(j, k, l) = flux_src_rsx_vf(j, k, l, advxb) end do end do end do @@ -5201,8 +4729,7 @@ contains 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) + flux_src_vf(i)%sf(j, k, l) = flux_src_rsx_vf(j, k, l, i) end do end do end do @@ -5210,12 +4737,9 @@ contains $: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 - if (viscous) then @:DEALLOCATE(Re_avg_rsx_vf) end if @@ -5252,7 +4776,5 @@ contains if (qbmm) then @:DEALLOCATE(mom_sp_rsz_vf) end if - end subroutine s_finalize_riemann_solvers_module - end module m_riemann_solvers diff --git a/src/simulation/m_sim_helpers.fpp b/src/simulation/m_sim_helpers.fpp index a7680f84e9..3f2612aa0a 100644 --- a/src/simulation/m_sim_helpers.fpp +++ b/src/simulation/m_sim_helpers.fpp @@ -7,7 +7,6 @@ !> @brief Simulation helper routines for enthalpy computation, CFL calculation, and stability checks module m_sim_helpers - use m_derived_types !< Definitions of the derived types use m_global_parameters @@ -16,10 +15,7 @@ module m_sim_helpers implicit none - private; public :: s_compute_enthalpy, & - s_compute_stability_from_dt, & - s_compute_dt_from_cfl - + private; public :: s_compute_enthalpy, s_compute_stability_from_dt, s_compute_dt_from_cfl contains !> Computes the modified dtheta for Fourier filtering in azimuthal direction @@ -29,13 +25,13 @@ contains function f_compute_filtered_dtheta(k, l) result(fltr_dtheta) $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: k, l - real(wp) :: fltr_dtheta - integer :: Nfq + real(wp) :: fltr_dtheta + integer :: Nfq if (grid_geometry == 3) then if (k == 0) then fltr_dtheta = 2._wp*pi*y_cb(0)/3._wp - elseif (k <= fourier_rings) then + else if (k <= fourier_rings) then Nfq = min(floor(2._wp*real(k, wp)*pi), (p + 1)/2 + 1) fltr_dtheta = 2._wp*pi*y_cb(k - 1)/real(Nfq, wp) else @@ -45,7 +41,6 @@ contains fltr_dtheta = 0._wp end if end function f_compute_filtered_dtheta - !> Computes inviscid CFL terms for multi-dimensional cases (2D/3D only) !! @param vel directional velocities !! @param c mixture speed of sound @@ -56,33 +51,27 @@ contains function f_compute_multidim_cfl_terms(vel, c, j, k, l) result(cfl_terms) $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(num_vels), intent(in) :: vel - real(wp), intent(in) :: c - integer, intent(in) :: j, k, l - real(wp) :: cfl_terms - real(wp) :: fltr_dtheta + real(wp), intent(in) :: c + integer, intent(in) :: j, k, l + real(wp) :: cfl_terms + real(wp) :: fltr_dtheta fltr_dtheta = f_compute_filtered_dtheta(k, l) if (p > 0) then - !3D + ! 3D #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 if (grid_geometry == 3) then - cfl_terms = min(dx(j)/(abs(vel(1)) + c), & - dy(k)/(abs(vel(2)) + c), & - fltr_dtheta/(abs(vel(3)) + c)) + cfl_terms = min(dx(j)/(abs(vel(1)) + c), dy(k)/(abs(vel(2)) + c), fltr_dtheta/(abs(vel(3)) + c)) else - cfl_terms = min(dx(j)/(abs(vel(1)) + c), & - dy(k)/(abs(vel(2)) + c), & - dz(l)/(abs(vel(3)) + c)) + cfl_terms = min(dx(j)/(abs(vel(1)) + c), dy(k)/(abs(vel(2)) + c), dz(l)/(abs(vel(3)) + c)) end if #:endif else - !2D - cfl_terms = min(dx(j)/(abs(vel(1)) + c), & - dy(k)/(abs(vel(2)) + c)) + ! 2D + cfl_terms = min(dx(j)/(abs(vel(1)) + c), dy(k)/(abs(vel(2)) + c)) end if end function f_compute_multidim_cfl_terms - !> Computes enthalpy !! @param q_prim_vf cell centered primitive variables !! @param pres mixture pressure @@ -99,8 +88,7 @@ contains !! @param k y index !! @param l z index subroutine s_compute_enthalpy(q_prim_vf, pres, rho, gamma, pi_inf, Re, H, alpha, vel, vel_sum, qv, j, k, l) - $:GPU_ROUTINE(function_name='s_compute_enthalpy',parallelism='[seq]', & - & cray_inline=True) + $:GPU_ROUTINE(function_name='s_compute_enthalpy',parallelism='[seq]', cray_inline=True) type(scalar_field), intent(in), dimension(sys_size) :: q_prim_vf #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -108,11 +96,11 @@ contains real(wp), intent(inout), dimension(3) :: vel #:else real(wp), intent(inout), dimension(num_fluids) :: alpha - real(wp), intent(inout), dimension(num_vels) :: vel + real(wp), intent(inout), dimension(num_vels) :: vel #:endif - real(wp), intent(inout) :: rho, gamma, pi_inf, vel_sum, H, pres - real(wp), intent(out) :: qv - integer, intent(in) :: j, k, l + real(wp), intent(inout) :: rho, gamma, pi_inf, vel_sum, H, pres + real(wp), intent(out) :: qv + integer, intent(in) :: j, k, l real(wp), dimension(2), intent(inout) :: Re #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha_rho, Gs @@ -120,14 +108,12 @@ contains real(wp), dimension(num_fluids) :: alpha_rho, Gs #:endif real(wp) :: E, G_local - - integer :: i + integer :: i call s_compute_species_fraction(q_prim_vf, j, k, l, alpha_rho, alpha) if (elasticity) then - call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, alpha, & - alpha_rho, Re, G_local, Gs) + call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, alpha, alpha_rho, Re, G_local, Gs) else call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, alpha, alpha_rho, Re) end if @@ -164,9 +150,7 @@ contains end if H = (E + pres)/rho - end subroutine s_compute_enthalpy - !> Computes stability criterion for a specified dt !! @param vel directional velocities !! @param c mixture speed of sound @@ -180,14 +164,13 @@ contains !! @param Rc_sf (optional) cell centered Rc subroutine s_compute_stability_from_dt(vel, c, rho, Re_l, j, k, l, icfl_sf, vcfl_sf, Rc_sf) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in), dimension(num_vels) :: vel - real(wp), intent(in) :: c, rho - real(wp), dimension(0:m, 0:n, 0:p), intent(inout) :: icfl_sf + real(wp), intent(in), dimension(num_vels) :: vel + real(wp), intent(in) :: c, rho + real(wp), dimension(0:m, 0:n, 0:p), intent(inout) :: icfl_sf real(wp), dimension(0:m, 0:n, 0:p), intent(inout), optional :: vcfl_sf, Rc_sf - real(wp), dimension(2), intent(in) :: Re_l - integer, intent(in) :: j, k, l - - real(wp) :: fltr_dtheta + real(wp), dimension(2), intent(in) :: Re_l + integer, intent(in) :: j, k, l + real(wp) :: fltr_dtheta ! Inviscid CFL calculation if (p > 0 .or. n > 0) then @@ -202,39 +185,29 @@ contains if (viscous) then if (p > 0) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - !3D + ! 3D if (grid_geometry == 3) then fltr_dtheta = f_compute_filtered_dtheta(k, l) - vcfl_sf(j, k, l) = maxval(dt/Re_l/rho) & - /min(dx(j), dy(k), fltr_dtheta)**2._wp - Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), & - dy(k)*(abs(vel(2)) + c), & - fltr_dtheta*(abs(vel(3)) + c)) & - /maxval(1._wp/Re_l) + vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/min(dx(j), dy(k), fltr_dtheta)**2._wp + Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), dy(k)*(abs(vel(2)) + c), & + & fltr_dtheta*(abs(vel(3)) + c))/maxval(1._wp/Re_l) else - vcfl_sf(j, k, l) = maxval(dt/Re_l/rho) & - /min(dx(j), dy(k), dz(l))**2._wp - Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), & - dy(k)*(abs(vel(2)) + c), & - dz(l)*(abs(vel(3)) + c)) & - /maxval(1._wp/Re_l) + vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/min(dx(j), dy(k), dz(l))**2._wp + Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), dy(k)*(abs(vel(2)) + c), & + & dz(l)*(abs(vel(3)) + c))/maxval(1._wp/Re_l) end if #:endif - elseif (n > 0) then - !2D + else if (n > 0) then + ! 2D vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/min(dx(j), dy(k))**2._wp - Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), & - dy(k)*(abs(vel(2)) + c)) & - /maxval(1._wp/Re_l) + Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), dy(k)*(abs(vel(2)) + c))/maxval(1._wp/Re_l) else - !1D + ! 1D vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/dx(j)**2._wp Rc_sf(j, k, l) = dx(j)*(abs(vel(1)) + c)/maxval(1._wp/Re_l) end if end if - end subroutine s_compute_stability_from_dt - !> Computes dt for a specified CFL number !! @param vel directional velocities !! @param c Speed of sound @@ -246,14 +219,13 @@ contains !! @param l z coordinate subroutine s_compute_dt_from_cfl(vel, c, max_dt, rho, Re_l, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), dimension(num_vels), intent(in) :: vel - real(wp), intent(in) :: c, rho + real(wp), dimension(num_vels), intent(in) :: vel + real(wp), intent(in) :: c, rho real(wp), dimension(0:m, 0:n, 0:p), intent(inout) :: max_dt - real(wp), dimension(2), intent(in) :: Re_l - integer, intent(in) :: j, k, l - - real(wp) :: icfl_dt, vcfl_dt - real(wp) :: fltr_dtheta + real(wp), dimension(2), intent(in) :: Re_l + integer, intent(in) :: j, k, l + real(wp) :: icfl_dt, vcfl_dt + real(wp) :: fltr_dtheta ! Inviscid CFL calculation if (p > 0 .or. n > 0) then @@ -267,20 +239,18 @@ contains ! Viscous calculations if (viscous) then if (p > 0) then - !3D + ! 3D if (grid_geometry == 3) then fltr_dtheta = f_compute_filtered_dtheta(k, l) - vcfl_dt = cfl_target*(min(dx(j), dy(k), fltr_dtheta)**2._wp) & - /maxval(1/(rho*Re_l)) + vcfl_dt = cfl_target*(min(dx(j), dy(k), fltr_dtheta)**2._wp)/maxval(1/(rho*Re_l)) else - vcfl_dt = cfl_target*(min(dx(j), dy(k), dz(l))**2._wp) & - /maxval(1/(rho*Re_l)) + vcfl_dt = cfl_target*(min(dx(j), dy(k), dz(l))**2._wp)/maxval(1/(rho*Re_l)) end if - elseif (n > 0) then - !2D + else if (n > 0) then + ! 2D vcfl_dt = cfl_target*(min(dx(j), dy(k))**2._wp)/maxval((1/Re_l)/rho) else - !1D + ! 1D vcfl_dt = cfl_target*(dx(j)**2._wp)/maxval(1/(rho*Re_l)) end if end if @@ -290,7 +260,5 @@ contains else max_dt(j, k, l) = icfl_dt end if - end subroutine s_compute_dt_from_cfl - end module m_sim_helpers diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 4c670fc686..0e48d9c4f8 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -7,7 +7,6 @@ !> @brief Reads input files, loads initial conditions and grid data, and orchestrates solver initialization and finalization module m_start_up - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -84,48 +83,31 @@ module m_start_up implicit none - private; public :: s_read_input_file, & - s_check_input_file, & - s_read_data_files, & - s_read_serial_data_files, & - s_read_parallel_data_files, & - s_initialize_internal_energy_equations, & - s_initialize_modules, s_initialize_gpu_vars, & - s_initialize_mpi_domain, s_finalize_modules, & - s_perform_time_step, s_save_data, & - s_save_performance_metrics + private; public :: s_read_input_file, s_check_input_file, s_read_data_files, s_read_serial_data_files, & + & s_read_parallel_data_files, s_initialize_internal_energy_equations, s_initialize_modules, s_initialize_gpu_vars, & + & s_initialize_mpi_domain, s_finalize_modules, s_perform_time_step, s_save_data, s_save_performance_metrics type(scalar_field), allocatable, dimension(:) :: q_cons_temp - - real(wp) :: dt_init - + real(wp) :: dt_init contains !> Read data files. Dispatch subroutine that replaces procedure pointer. !! @param q_cons_vf Conservative variables impure subroutine s_read_data_files(q_cons_vf) - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: q_cons_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf if (.not. parallel_io) then call s_read_serial_data_files(q_cons_vf) else call s_read_parallel_data_files(q_cons_vf) end if - end subroutine s_read_data_files - - !> The purpose of this procedure is to first verify that an - !! input file has been made available by the user. Provided - !! that this is so, the input file is then read in. + !> The purpose of this procedure is to first verify that an input file has been made available by the user. Provided that this + !! is so, the input file is then read in. impure subroutine s_read_input_file - ! Relative path to the input file provided by the user character(LEN=name_len), parameter :: file_path = './simulation.inp' - - logical :: file_exist !< + logical :: file_exist !< !! Logical used to check the existence of the input file integer :: iostatus @@ -151,50 +133,33 @@ contains null_weights, precision, parallel_io, cyl_coord, & rhoref, pref, bubbles_euler, bubble_model, & R0ref, chem_params, & -#:if not MFC_CASE_OPTIMIZATION + #:if not MFC_CASE_OPTIMIZATION nb, mapped_weno, wenoz, teno, wenoz_q, weno_order, & num_fluids, mhd, relativity, igr_order, viscous, & igr_iter_solver, igr, igr_pres_lim, & recon_type, muscl_order, muscl_lim, & -#:endif - Ca, Web, Re_inv, & - acoustic_source, acoustic, num_source, & - polytropic, thermal, & - integral, integral_wrt, num_integrals, & - polydisperse, poly_sigma, qbmm, & - relax, relax_model, & - palpha_eps, ptgalpha_eps, & - file_per_process, sigma, & - pi_fac, adv_n, adap_dt, adap_dt_tol, adap_dt_max_iters, & - bf_x, bf_y, bf_z, & - k_x, k_y, k_z, w_x, w_y, w_z, p_x, p_y, p_z, & - g_x, g_y, g_z, n_start, t_save, t_stop, & - cfl_adap_dt, cfl_const_dt, cfl_target, & - surface_tension, bubbles_lagrange, lag_params, & - hyperelasticity, R0ref, num_bc_patches, Bx0, & - cont_damage, tau_star, cont_damage_s, alpha_bar, & - hyper_cleaning, hyper_cleaning_speed, hyper_cleaning_tau, & - alf_factor, num_igr_iters, num_igr_warm_start_iters, & - int_comp, ic_eps, ic_beta, nv_uvm_out_of_core, & - nv_uvm_igr_temps_on_gpu, nv_uvm_pref_gpu, down_sample, fft_wrt + #:endif + Ca, Web, Re_inv, acoustic_source, acoustic, num_source, polytropic, thermal, integral, integral_wrt, num_integrals, & + & polydisperse, poly_sigma, qbmm, relax, relax_model, palpha_eps, ptgalpha_eps, file_per_process, sigma, pi_fac, & + & adv_n, adap_dt, adap_dt_tol, adap_dt_max_iters, bf_x, bf_y, bf_z, k_x, k_y, k_z, w_x, w_y, w_z, p_x, p_y, p_z, g_x, & + & g_y, g_z, n_start, t_save, t_stop, cfl_adap_dt, cfl_const_dt, cfl_target, surface_tension, bubbles_lagrange, & + & lag_params, hyperelasticity, R0ref, num_bc_patches, Bx0, cont_damage, tau_star, cont_damage_s, alpha_bar, & + & hyper_cleaning, hyper_cleaning_speed, hyper_cleaning_tau, alf_factor, num_igr_iters, num_igr_warm_start_iters, & + & int_comp, ic_eps, ic_beta, nv_uvm_out_of_core, nv_uvm_igr_temps_on_gpu, nv_uvm_pref_gpu, down_sample, fft_wrt ! Checking that an input file has been provided by the user. If it ! has, then the input file is read in, otherwise, simulation exits. inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then - open (1, FILE=trim(file_path), & - FORM='formatted', & - ACTION='read', & - STATUS='old') + open (1, FILE=trim(file_path), form='formatted', ACTION='read', STATUS='old') read (1, NML=user_inputs, iostat=iostatus) if (iostatus /= 0) then backspace (1) read (1, fmt='(A)') line - print *, 'Invalid line in namelist: '//trim(line) - call s_mpi_abort('Invalid line in simulation.inp. It is '// & - 'likely due to a datatype mismatch. Exiting.') + print *, 'Invalid line in namelist: ' // trim(line) + call s_mpi_abort('Invalid line in simulation.inp. It is ' // 'likely due to a datatype mismatch. Exiting.') end if close (1) @@ -212,22 +177,16 @@ contains if (cfl_adap_dt .or. cfl_const_dt) cfl_dt = .true. - if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == -17) .or. & - num_bc_patches > 0) then + if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == -17) .or. num_bc_patches > 0) then bc_io = .true. end if - else - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if - end subroutine s_read_input_file - - !> The goal of this procedure is to verify that each of the - !! user provided inputs is valid and that their combination - !! constitutes a meaningful configuration for the simulation. + !> The goal of this procedure is to verify that each of the user provided inputs is valid and that their combination constitutes + !! a meaningful configuration for the simulation. impure subroutine s_check_input_file - ! Relative path to the current directory file in the case directory character(LEN=path_len) :: file_path @@ -235,26 +194,22 @@ contains logical :: file_exist ! Logistics - file_path = trim(case_dir)//'/.' + file_path = trim(case_dir) // '/.' call my_inquire(file_path, file_exist) if (file_exist .neqv. .true.) then - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if call s_check_inputs_common() call s_check_inputs() - end subroutine s_check_input_file - !> @brief Reads serial initial condition and grid data files and computes cell-width distributions. !! @param q_cons_vf Cell-averaged conservative variables impure subroutine s_read_serial_data_files(q_cons_vf) - - type(scalar_field), dimension(sys_size), intent(INOUT) :: q_cons_vf - - character(LEN=path_len + 2*name_len) :: t_step_dir !< + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + character(LEN=path_len + 2*name_len) :: t_step_dir !< !! Relative path to the starting time-step directory character(LEN=path_len + 3*name_len) :: file_path !< @@ -268,18 +223,16 @@ contains ! Confirming that the directory from which the initial condition and ! the grid data files are to be read in exists and exiting otherwise if (cfl_dt) then - write (t_step_dir, '(A,I0,A,I0)') & - trim(case_dir)//'/p_all/p', proc_rank, '/', n_start + write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all/p', proc_rank, '/', n_start else - write (t_step_dir, '(A,I0,A,I0)') & - trim(case_dir)//'/p_all/p', proc_rank, '/', t_step_start + write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all/p', proc_rank, '/', t_step_start end if - file_path = trim(t_step_dir)//'/.' + file_path = trim(t_step_dir) // '/.' call my_inquire(file_path, file_exist) if (file_exist .neqv. .true.) then - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if if (bc_io) then @@ -289,18 +242,15 @@ contains end if ! Cell-boundary Locations in x-direction - file_path = trim(t_step_dir)//'/x_cb.dat' + file_path = trim(t_step_dir) // '/x_cb.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then - open (2, FILE=trim(file_path), & - FORM='unformatted', & - ACTION='read', & - STATUS='old') + open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') read (2) x_cb(-1:m); close (2) else - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if dx(0:m) = x_cb(0:m) - x_cb(-1:m - 1) @@ -309,67 +259,54 @@ contains if (ib) then do i = 1, num_ibs if (patch_ib(i)%c > 0) then - Np = int((patch_ib(i)%p*patch_ib(i)%c/dx(0))*20) + int(((patch_ib(i)%c - patch_ib(i)%p*patch_ib(i)%c)/dx(0))*20) + 1 + Np = int((patch_ib(i)%p*patch_ib(i)%c/dx(0))*20) + int(((patch_ib(i)%c - patch_ib(i)%p*patch_ib(i)%c)/dx(0)) & + & *20) + 1 end if end do end if ! Cell-boundary Locations in y-direction if (n > 0) then - - file_path = trim(t_step_dir)//'/y_cb.dat' + file_path = trim(t_step_dir) // '/y_cb.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then - open (2, FILE=trim(file_path), & - FORM='unformatted', & - ACTION='read', & - STATUS='old') + open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') read (2) y_cb(-1:n); close (2) else - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if dy(0:n) = y_cb(0:n) - y_cb(-1:n - 1) y_cc(0:n) = y_cb(-1:n - 1) + dy(0:n)/2._wp - end if ! Cell-boundary Locations in z-direction if (p > 0) then - - file_path = trim(t_step_dir)//'/z_cb.dat' + file_path = trim(t_step_dir) // '/z_cb.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then - open (2, FILE=trim(file_path), & - FORM='unformatted', & - ACTION='read', & - STATUS='old') + open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') read (2) z_cb(-1:p); close (2) else - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if dz(0:p) = z_cb(0:p) - z_cb(-1:p - 1) z_cc(0:p) = z_cb(-1:p - 1) + dz(0:p)/2._wp - end if do i = 1, sys_size - write (file_path, '(A,I0,A)') & - trim(t_step_dir)//'/q_cons_vf', i, '.dat' + write (file_path, '(A,I0,A)') trim(t_step_dir) // '/q_cons_vf', i, '.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then - open (2, FILE=trim(file_path), & - FORM='unformatted', & - ACTION='read', & - STATUS='old') + open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') read (2) q_cons_vf(i)%sf(0:m, 0:n, 0:p); close (2) else - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if end do @@ -378,67 +315,50 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A)') & - trim(t_step_dir)//'/pb', sys_size + (i - 1)*nnode + r, '.dat' + write (file_path, '(A,I0,A)') trim(t_step_dir) // '/pb', sys_size + (i - 1)*nnode + r, '.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then - open (2, FILE=trim(file_path), & - FORM='unformatted', & - ACTION='read', & - STATUS='old') + open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') read (2) pb_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) else - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if end do end do do i = 1, nb do r = 1, nnode - write (file_path, '(A,I0,A)') & - trim(t_step_dir)//'/mv', sys_size + (i - 1)*nnode + r, '.dat' + write (file_path, '(A,I0,A)') trim(t_step_dir) // '/mv', sys_size + (i - 1)*nnode + r, '.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then - open (2, FILE=trim(file_path), & - FORM='unformatted', & - ACTION='read', & - STATUS='old') + open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') read (2) mv_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) else - call s_mpi_abort(trim(file_path)//' is missing. Exiting.') + call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if end do end do end if end if - end subroutine s_read_serial_data_files - !> @brief Reads parallel initial condition and grid data files via MPI I/O. !! @param q_cons_vf Conservative variables impure subroutine s_read_parallel_data_files(q_cons_vf) - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: q_cons_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf #ifdef MFC_MPI - real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb - - integer :: ifile, ierr, data_size - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer(KIND=MPI_OFFSET_KIND) :: m_MOK, n_MOK, p_MOK - integer(KIND=MPI_OFFSET_KIND) :: WP_MOK, var_MOK, str_MOK - integer(KIND=MPI_OFFSET_KIND) :: NVARS_MOK - integer(KIND=MPI_OFFSET_KIND) :: MOK - + real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb + integer :: ifile, ierr, data_size + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer(KIND=MPI_OFFSET_KIND) :: m_MOK, n_MOK, p_MOK + integer(KIND=MPI_OFFSET_KIND) :: WP_MOK, var_MOK, str_MOK + integer(KIND=MPI_OFFSET_KIND) :: NVARS_MOK + integer(KIND=MPI_OFFSET_KIND) :: MOK character(LEN=path_len + 2*name_len) :: file_loc - logical :: file_exist - - character(len=10) :: t_step_start_string - - integer :: i, j + logical :: file_exist + character(len=10) :: t_step_start_string + integer :: i, j ! Downsampled data variables integer :: m_ds, n_ds, p_ds @@ -450,7 +370,7 @@ contains allocate (z_cb_glb(-1:p_glb)) ! Read in cell boundary locations in x-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'x_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'x_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (down_sample) then @@ -469,7 +389,7 @@ contains call MPI_FILE_READ(ifile, x_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if ! Assigning local cell boundary locations @@ -482,7 +402,8 @@ contains if (ib) then do i = 1, num_ibs if (patch_ib(i)%c > 0) then - Np = int((patch_ib(i)%p*patch_ib(i)%c/dx(0))*20) + int(((patch_ib(i)%c - patch_ib(i)%p*patch_ib(i)%c)/dx(0))*20) + 1 + Np = int((patch_ib(i)%p*patch_ib(i)%c/dx(0))*20) + int(((patch_ib(i)%c - patch_ib(i)%p*patch_ib(i)%c)/dx(0)) & + & *20) + 1 allocate (MPI_IO_airfoil_IB_DATA%var(1:2*Np)) end if end do @@ -490,7 +411,7 @@ contains if (n > 0) then ! Read in cell boundary locations in y-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'y_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'y_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -499,7 +420,7 @@ contains call MPI_FILE_READ(ifile, y_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if ! Assigning local cell boundary locations @@ -511,7 +432,7 @@ contains if (p > 0) then ! Read in cell boundary locations in z-direction - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//'z_cb.dat' + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'z_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -520,7 +441,7 @@ contains call MPI_FILE_READ(ifile, z_cb_glb, data_size, mpi_p, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) else - call s_mpi_abort('File '//trim(file_loc)//'is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // 'is missing. Exiting.') end if ! Assigning local cell boundary locations @@ -529,7 +450,6 @@ contains dz(0:p) = z_cb(0:p) - z_cb(-1:p - 1) ! Computing the cell center locations z_cc(0:p) = z_cb(-1:p - 1) + dz(0:p)/2._wp - end if end if @@ -541,7 +461,7 @@ contains call s_int_to_str(t_step_start, t_step_start_string) write (file_loc, '(I0,A1,I7.7,A)') t_step_start, '_', proc_rank, '.dat' end if - file_loc = trim(case_dir)//'/restart_data/lustre_'//trim(t_step_start_string)//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data/lustre_' // trim(t_step_start_string) // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -583,19 +503,17 @@ contains ! Read the data for each variable if (bubbles_euler .or. elasticity) then - do i = 1, sys_size!adv_idx%end + do i = 1, sys_size ! adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - !Read pb and mv for non-polytropic qbmm + ! Read pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if else @@ -603,15 +521,13 @@ contains do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_READ(ifile, q_cons_temp(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_READ(ifile, q_cons_temp(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do else do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if end if @@ -619,9 +535,8 @@ contains call s_mpi_barrier() call MPI_FILE_CLOSE(ifile, ierr) - else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if else ! Open the file to read conservative variables @@ -630,7 +545,7 @@ contains else write (file_loc, '(I0,A)') t_step_start, '.dat' end if - file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) + file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) if (file_exist) then @@ -643,7 +558,6 @@ contains else call s_initialize_mpi_data(q_cons_vf) - end if ! Size of local arrays @@ -660,27 +574,23 @@ contains ! Read the data for each variable if (bubbles_euler .or. elasticity) then - do i = 1, sys_size !adv_idx%end + do i = 1, sys_size ! adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - !Read pb and mv for non-polytropic qbmm + ! Read pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if else @@ -690,21 +600,17 @@ contains ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) - call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), & - 'native', mpi_info_int, ierr) - call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, & - mpi_io_p, status, ierr) + call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) + call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do end if call s_mpi_barrier() call MPI_FILE_CLOSE(ifile, ierr) - else - call s_mpi_abort('File '//trim(file_loc)//' is missing. Exiting.') + call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if - end if deallocate (x_cb_glb, y_cb_glb, z_cb_glb) @@ -714,33 +620,23 @@ contains else call s_assign_default_bc_type(bc_type) end if - #endif - end subroutine s_read_parallel_data_files - - !> The purpose of this procedure is to initialize the - !! values of the internal-energy equations of each phase - !! from the mass of each phase, the mixture momentum and - !! mixture-total-energy equations. + !> The purpose of this procedure is to initialize the values of the internal-energy equations of each phase from the mass of + !! each phase, the mixture momentum and mixture-total-energy equations. !! @param v_vf conservative variables subroutine s_initialize_internal_energy_equations(v_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: v_vf - - real(wp) :: rho - real(wp) :: dyn_pres - real(wp) :: gamma - real(wp) :: pi_inf - real(wp) :: qv - real(wp), dimension(2) :: Re - real(wp) :: pres, T - - integer :: i, j, k, l, c - - real(wp), dimension(num_species) :: rhoYks - - real(wp) :: pres_mag + real(wp) :: rho + real(wp) :: dyn_pres + real(wp) :: gamma + real(wp) :: pi_inf + real(wp) :: qv + real(wp), dimension(2) :: Re + real(wp) :: pres, T + integer :: i, j, k, l, c + real(wp), dimension(num_species) :: rhoYks + real(wp) :: pres_mag pres_mag = 0._wp @@ -749,13 +645,11 @@ contains do j = 0, m do k = 0, n do l = 0, p - call s_convert_to_mixture_variables(v_vf, j, k, l, rho, gamma, pi_inf, qv, Re) dyn_pres = 0._wp do i = mom_idx%beg, mom_idx%end - dyn_pres = dyn_pres + 5.e-1_wp*v_vf(i)%sf(j, k, l)*v_vf(i)%sf(j, k, l) & - /max(rho, sgm_eps) + dyn_pres = dyn_pres + 5.e-1_wp*v_vf(i)%sf(j, k, l)*v_vf(i)%sf(j, k, l)/max(rho, sgm_eps) end do if (chemistry) then @@ -768,30 +662,27 @@ contains if (n == 0) then pres_mag = 0.5_wp*(Bx0**2 + v_vf(B_idx%beg)%sf(j, k, l)**2 + v_vf(B_idx%beg + 1)%sf(j, k, l)**2) else - pres_mag = 0.5_wp*(v_vf(B_idx%beg)%sf(j, k, l)**2 + v_vf(B_idx%beg + 1)%sf(j, k, l)**2 + v_vf(B_idx%beg + 2)%sf(j, k, l)**2) + pres_mag = 0.5_wp*(v_vf(B_idx%beg)%sf(j, k, l)**2 + v_vf(B_idx%beg + 1)%sf(j, k, & + & l)**2 + v_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if end if - call s_compute_pressure(v_vf(E_idx)%sf(j, k, l), 0._stp, & - dyn_pres, pi_inf, gamma, rho, qv, rhoYks, pres, T, pres_mag=pres_mag) + call s_compute_pressure(v_vf(E_idx)%sf(j, k, l), 0._stp, dyn_pres, pi_inf, gamma, rho, qv, rhoYks, pres, T, & + & pres_mag=pres_mag) do i = 1, num_fluids - v_vf(i + intxb - 1)%sf(j, k, l) = v_vf(i + advxb - 1)%sf(j, k, l)*(gammas(i)*pres + pi_infs(i)) & - + v_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) + v_vf(i + intxb - 1)%sf(j, k, l) = v_vf(i + advxb - 1)%sf(j, k, & + & l)*(gammas(i)*pres + pi_infs(i)) + v_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) end do - end do end do end do - end subroutine s_initialize_internal_energy_equations - !> @brief Advances the simulation by one time step, handling CFL-based dt and time-stepper dispatch. impure subroutine s_perform_time_step(t_step, time_avg) - integer, intent(inout) :: t_step + integer, intent(inout) :: t_step real(wp), intent(inout) :: time_avg - - integer :: i + integer :: i if (cfl_dt) then if (cfl_const_dt .and. t_step == 0) call s_compute_dt() @@ -820,23 +711,11 @@ contains if (cfl_dt) then if (proc_rank == 0 .and. mod(t_step - t_step_start, t_step_print) == 0) then - print '(" [", I3, "%] Time ", ES16.6, " dt = ", ES16.6, " @ Time Step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', & - int(ceiling(100._wp*(mytime/t_stop))), & - mytime, & - dt, & - t_step, & - wall_time_avg, & - wall_time + print '(" [", I3, "%] Time ", ES16.6, " dt = ", ES16.6, " @ Time Step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', int(ceiling(100._wp*(mytime/t_stop))), mytime, dt, t_step, wall_time_avg, wall_time end if else if (proc_rank == 0 .and. mod(t_step - t_step_start, t_step_print) == 0) then - print '(" [", I3, "%] Time step ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES12.6, " Time/step= ", ES12.6, "")', & - int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & - t_step - t_step_start + 1, & - t_step_stop - t_step_start + 1, & - t_step, & - wall_time_avg, & - wall_time + print '(" [", I3, "%] Time step ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES12.6, " Time/step= ", ES12.6, "")', int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), t_step - t_step_start + 1, t_step_stop - t_step_start + 1, t_step, wall_time_avg, wall_time end if end if @@ -858,19 +737,17 @@ contains ! Time-stepping loop controls t_step = t_step + 1 - end subroutine s_perform_time_step - !> @brief Collects per-process wall-clock times and writes aggregate performance metrics to file. - impure subroutine s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, file_exists) + impure subroutine s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & + & file_exists) - real(wp), intent(inout) :: time_avg, time_final - real(wp), intent(inout) :: io_time_avg, io_time_final + real(wp), intent(inout) :: time_avg, time_final + real(wp), intent(inout) :: io_time_avg, io_time_final real(wp), dimension(:), intent(inout) :: proc_time real(wp), dimension(:), intent(inout) :: io_proc_time - logical, intent(inout) :: file_exists - - real(wp) :: grind_time + logical, intent(inout) :: file_exists + real(wp) :: grind_time call s_mpi_barrier() @@ -891,9 +768,8 @@ contains io_time_final = maxval(io_proc_time) end if - grind_time = time_final*1.0e9_wp/ & - (real(sys_size, wp)*real(maxval((/1, m_glb/)), wp)* & - real(maxval((/1, n_glb/)), wp)*real(maxval((/1, p_glb/)), wp)) + grind_time = time_final*1.0e9_wp/(real(sys_size, wp)*real(maxval((/1, m_glb/)), wp)*real(maxval((/1, n_glb/)), & + & wp)*real(maxval((/1, p_glb/)), wp)) print *, "Performance:", grind_time, "ns/gp/eq/rhs" inquire (FILE='time_data.dat', EXIST=file_exists) @@ -918,21 +794,16 @@ contains write (1, '(I10, F15.8)') num_procs, io_time_final close (1) - end if - end subroutine s_save_performance_metrics - !> @brief Saves conservative variable data to disk at the current time step. impure subroutine s_save_data(t_step, start, finish, io_time_avg, nt) - integer, intent(inout) :: t_step + integer, intent(inout) :: t_step real(wp), intent(inout) :: start, finish, io_time_avg - integer, intent(inout) :: nt - - integer(kind=8) :: i, j, k, l - integer :: stor - - integer :: save_count + integer, intent(inout) :: nt + integer(kind=8) :: i, j, k, l + integer :: stor + integer :: save_count if (down_sample) then call s_populate_variables_buffers(bc_type, q_cons_ts(1)%vf) @@ -946,8 +817,7 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end - q_cons_ts(2)%vf(i)%sf(j, k, l) = & - q_cons_ts(1)%vf(i)%sf(j, k, l) + q_cons_ts(2)%vf(i)%sf(j, k, l) = q_cons_ts(1)%vf(i)%sf(j, k, l) end do end do end do @@ -987,8 +857,7 @@ contains if (bubbles_lagrange) then $:GPU_UPDATE(host='[lag_id, mtn_pos, mtn_posPrev, mtn_vel, intfc_rad, & - & intfc_vel, bub_R0, Rmax_stats, Rmin_stats, bub_dphidt, gas_p, & - & gas_mv, gas_mg, gas_betaT, gas_betaC]') + & intfc_vel, bub_R0, Rmax_stats, Rmin_stats, bub_dphidt, gas_p, gas_mv, gas_mg, gas_betaT, gas_betaC]') do i = 1, nBubs if (ieee_is_nan(intfc_rad(i, 1)) .or. intfc_rad(i, 1) <= 0._wp) then call s_mpi_abort("Bubble radius is negative or NaN, please reduce dt.") @@ -997,8 +866,8 @@ contains $:GPU_UPDATE(host='[q_beta(1)%sf]') call s_write_data_files(q_cons_ts(stor)%vf, q_T_sf, q_prim_vf, save_count, bc_type, q_beta(1)) - $:GPU_UPDATE(host='[Rmax_stats,Rmin_stats,gas_p,gas_mv,intfc_vel]') - call s_write_restart_lag_bubbles(save_count) !parallel + $:GPU_UPDATE(host='[Rmax_stats, Rmin_stats, gas_p, gas_mv, intfc_vel]') + call s_write_restart_lag_bubbles(save_count) ! parallel if (lag_params%write_bubbles_stats) call s_write_lag_bubble_stats() else call s_write_data_files(q_cons_ts(stor)%vf, q_T_sf, q_prim_vf, save_count, bc_type) @@ -1017,14 +886,11 @@ contains else io_time_avg = (abs(finish - start) + io_time_avg*(nt - 1))/nt end if - end subroutine s_save_data - !> @brief Initializes all simulation sub-modules in the required dependency order. impure subroutine s_initialize_modules - - integer :: m_ds, n_ds, p_ds - integer :: i, j, k, l, x_id, y_id, z_id, ix, iy, iz + integer :: m_ds, n_ds, p_ds + integer :: i, j, k, l, x_id, y_id, z_id, ix, iy, iz real(wp) :: temp1, temp2, temp3, temp4 call s_initialize_global_parameters_module() @@ -1115,7 +981,7 @@ contains if (.not. igr .or. dummy) then if (recon_type == WENO_TYPE) then call s_initialize_weno_module() - elseif (recon_type == MUSCL_TYPE) then + else if (recon_type == MUSCL_TYPE) then call s_initialize_muscl_module() end if call s_initialize_cbc_module() @@ -1127,16 +993,14 @@ contains if (hypoelasticity) call s_initialize_hypoelastic_module() if (hyperelasticity) call s_initialize_hyperelastic_module() - end subroutine s_initialize_modules - !> @brief Sets up the MPI execution environment, binds GPUs, and decomposes the computational domain. impure subroutine s_initialize_mpi_domain integer :: ierr #ifdef MFC_GPU real(wp) :: starttime, endtime - integer :: num_devices, local_size, num_nodes, ppn, my_device_num - integer :: dev, devNum, local_rank + integer :: num_devices, local_size, num_nodes, ppn, my_device_num + integer :: dev, devNum, local_rank #ifdef MFC_MPI integer :: local_comm #endif @@ -1155,8 +1019,7 @@ contains local_size = 1 local_rank = 0 #else - call MPI_Comm_split_type(MPI_COMM_WORLD, MPI_COMM_TYPE_SHARED, 0, & - MPI_INFO_NULL, local_comm, ierr) + call MPI_Comm_split_type(MPI_COMM_WORLD, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, local_comm, ierr) call MPI_Comm_size(local_comm, local_size, ierr) call MPI_Comm_rank(local_comm, local_rank, ierr) #endif @@ -1183,14 +1046,14 @@ contains call s_check_input_file() print '(" Simulating a ", A, " ", I0, "x", I0, "x", I0, " case on ", I0, " rank(s) ", A, ".")', & -#:if not MFC_CASE_OPTIMIZATION + #:if not MFC_CASE_OPTIMIZATION "regular", & -#:else + #:else "case-optimized", & -#:endif - m, n, p, num_procs, & + #:endif + m, n, p, num_procs, & #if defined(MFC_OpenACC) - "with OpenACC offloading" + "with OpenACC offloading" #elif defined(MFC_OpenMP) "with OpenMP offloading" #else @@ -1207,13 +1070,11 @@ contains call s_initialize_parallel_io() call s_mpi_decompose_computational_domain() - end subroutine s_initialize_mpi_domain - !> @brief Transfers initial conservative variable and model parameter data to the GPU device. subroutine s_initialize_gpu_vars integer :: i - !Update GPU DATA + ! Update GPU DATA if (.not. down_sample) then do i = 1, sys_size $:GPU_UPDATE(device='[q_cons_ts(1)%vf(i)%sf]') @@ -1221,7 +1082,7 @@ contains end if if (qbmm .and. .not. polytropic) then - $:GPU_UPDATE(device='[pb_ts(1)%sf,mv_ts(1)%sf]') + $:GPU_UPDATE(device='[pb_ts(1)%sf, mv_ts(1)%sf]') end if if (chemistry) then $:GPU_UPDATE(device='[q_T_sf%sf]') @@ -1230,35 +1091,33 @@ contains $:GPU_UPDATE(device='[chem_params]') $:GPU_UPDATE(device='[R0ref,p0ref,rho0ref,ss,pv,vd,mu_l,mu_v,mu_g, & - & gam_v,gam_g,M_v,M_g,R_v,R_g,Tw,cp_v,cp_g,k_vl,k_gl, & - & gam, gam_m,Eu,Ca,Web,Re_inv,Pe_c,phi_vg,phi_gv,omegaN, & - & bubbles_euler,polytropic,polydisperse,qbmm, & - & ptil,bubble_model,thermal,poly_sigma,adv_n,adap_dt, & - & adap_dt_tol,adap_dt_max_iters,n_idx,pi_fac,low_Mach]') + & gam_v, gam_g, M_v, M_g, R_v, R_g, Tw, cp_v, cp_g, k_vl, k_gl, gam, gam_m, Eu, Ca, Web, Re_inv, Pe_c, phi_vg, phi_gv, & + & omegaN, bubbles_euler, polytropic, polydisperse, qbmm, ptil, bubble_model, thermal, poly_sigma, adv_n, adap_dt, & + & adap_dt_tol, adap_dt_max_iters, n_idx, pi_fac, low_Mach]') if (bubbles_euler) then - $:GPU_UPDATE(device='[weight,R0]') + $:GPU_UPDATE(device='[weight, R0]') if (.not. polytropic) then $:GPU_UPDATE(device='[pb0,Pe_T,k_g,k_v,mass_g0,mass_v0, & - & Re_trans_T,Re_trans_c,Im_trans_T,Im_trans_c]') + & Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c]') else if (qbmm) then $:GPU_UPDATE(device='[pb0]') end if end if - $:GPU_UPDATE(device='[adv_n,adap_dt,adap_dt_tol,adap_dt_max_iters,n_idx,pi_fac,low_Mach]') + $:GPU_UPDATE(device='[adv_n, adap_dt, adap_dt_tol, adap_dt_max_iters, n_idx, pi_fac, low_Mach]') $:GPU_UPDATE(device='[acoustic_source, num_source]') $:GPU_UPDATE(device='[sigma, surface_tension]') - $:GPU_UPDATE(device='[dx,dy,dz,x_cb,x_cc,y_cb,y_cc,z_cb,z_cc]') - $:GPU_UPDATE(device='[bc_x%vb1,bc_x%vb2,bc_x%vb3,bc_x%ve1,bc_x%ve2,bc_x%ve3]') - $:GPU_UPDATE(device='[bc_y%vb1,bc_y%vb2,bc_y%vb3,bc_y%ve1,bc_y%ve2,bc_y%ve3]') - $:GPU_UPDATE(device='[bc_z%vb1,bc_z%vb2,bc_z%vb3,bc_z%ve1,bc_z%ve2,bc_z%ve3]') + $:GPU_UPDATE(device='[dx, dy, dz, x_cb, x_cc, y_cb, y_cc, z_cb, z_cc]') + $:GPU_UPDATE(device='[bc_x%vb1, bc_x%vb2, bc_x%vb3, bc_x%ve1, bc_x%ve2, bc_x%ve3]') + $:GPU_UPDATE(device='[bc_y%vb1, bc_y%vb2, bc_y%vb3, bc_y%ve1, bc_y%ve2, bc_y%ve3]') + $:GPU_UPDATE(device='[bc_z%vb1, bc_z%vb2, bc_z%vb3, bc_z%ve1, bc_z%ve2, bc_z%ve3]') - $:GPU_UPDATE(device='[bc_x%grcbc_in,bc_x%grcbc_out,bc_x%grcbc_vel_out]') - $:GPU_UPDATE(device='[bc_y%grcbc_in,bc_y%grcbc_out,bc_y%grcbc_vel_out]') - $:GPU_UPDATE(device='[bc_z%grcbc_in,bc_z%grcbc_out,bc_z%grcbc_vel_out]') + $:GPU_UPDATE(device='[bc_x%grcbc_in, bc_x%grcbc_out, bc_x%grcbc_vel_out]') + $:GPU_UPDATE(device='[bc_y%grcbc_in, bc_y%grcbc_out, bc_y%grcbc_vel_out]') + $:GPU_UPDATE(device='[bc_z%grcbc_in, bc_z%grcbc_out, bc_z%grcbc_vel_out]') $:GPU_UPDATE(device='[relax, relax_model]') if (relax) then @@ -1269,7 +1128,7 @@ contains $:GPU_UPDATE(device='[ib_markers%sf]') end if #:if not MFC_CASE_OPTIMIZATION - $:GPU_UPDATE(device='[igr,nb,igr_order]') + $:GPU_UPDATE(device='[igr, nb, igr_order]') #:endif #:if USING_AMD block @@ -1279,12 +1138,9 @@ contains $:GPU_UPDATE(device='[molecular_weights_nonparameter]') end block #:endif - end subroutine s_initialize_gpu_vars - !> @brief Finalizes and deallocates all simulation sub-modules in reverse initialization order. impure subroutine s_finalize_modules - call s_finalize_time_steppers_module() if (hypoelasticity) call s_finalize_hypoelastic_module() if (hyperelasticity) call s_finalize_hyperelastic_module() @@ -1298,7 +1154,7 @@ contains call s_finalize_riemann_solvers_module() if (recon_type == WENO_TYPE) then call s_finalize_weno_module() - elseif (recon_type == MUSCL_TYPE) then + else if (recon_type == MUSCL_TYPE) then call s_finalize_muscl_module() end if end if @@ -1320,5 +1176,4 @@ contains ! Terminating MPI execution environment call s_mpi_finalize() end subroutine s_finalize_modules - end module m_start_up diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index c67375bc01..56f70418e5 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -8,7 +8,6 @@ !> @brief Computes capillary source fluxes and color-function gradients for the diffuse-interface surface tension model module m_surface_tension - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -28,10 +27,8 @@ module m_surface_tension implicit none - private; public :: s_initialize_surface_tension_module, & - s_compute_capillary_source_flux, & - s_get_capillary, & - s_finalize_surface_tension_module + private; public :: s_initialize_surface_tension_module, s_compute_capillary_source_flux, s_get_capillary, & + & s_finalize_surface_tension_module !> @name color function gradient components and magnitude !> @{ @@ -41,17 +38,15 @@ module m_surface_tension !> @name cell boundary reconstructed gradient components and magnitude !> @{ - real(wp), allocatable, dimension(:, :, :, :) :: gL_x, gR_x, gL_y, gR_y, gL_z, gR_z + real(wp), allocatable, dimension(:,:,:,:) :: gL_x, gR_x, gL_y, gR_y, gL_z, gR_z !> @} - $:GPU_DECLARE(create='[gL_x,gR_x,gL_y,gR_y,gL_z,gR_z]') + $:GPU_DECLARE(create='[gL_x, gR_x, gL_y, gR_y, gL_z, gR_z]') type(int_bounds_info) :: is1, is2, is3, iv - $:GPU_DECLARE(create='[is1,is2,is3,iv]') - + $:GPU_DECLARE(create='[is1, is2, is3, iv]') contains impure subroutine s_initialize_surface_tension_module - integer :: j @:ALLOCATE(c_divs(1:num_dims + 1)) @@ -72,21 +67,14 @@ contains @:ALLOCATE(gR_z(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, num_dims + 1)) end if end subroutine s_initialize_surface_tension_module - !> @brief Computes the capillary (surface-tension) source flux from reconstructed color-gradient fields. - subroutine s_compute_capillary_source_flux( & - vSrc_rsx_vf, vSrc_rsy_vf, vSrc_rsz_vf, & - flux_src_vf, & - id, isx, isy, isz) - - real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsx_vf - real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsy_vf - real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsz_vf - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_src_vf - integer, intent(in) :: id - type(int_bounds_info), intent(in) :: isx, isy, isz + subroutine s_compute_capillary_source_flux(vSrc_rsx_vf, vSrc_rsy_vf, vSrc_rsz_vf, flux_src_vf, id, isx, isy, isz) + real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsx_vf + real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsy_vf + real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: id + type(int_bounds_info), intent(in) :: isx, isy, isz #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3, 3) :: Omega #:else @@ -94,14 +82,13 @@ contains #:endif real(wp) :: w1L, w1R, w2L, w2R, w3L, w3R, w1, w2, w3 real(wp) :: normWL, normWR, normW - integer :: j, k, l, i + integer :: j, k, l, i if (id == 1) then $:GPU_PARALLEL_LOOP(collapse=3, private='[Omega, w1L, w2L, w3L, w1R, w2R, w3R, w1, w2, w3, normWL, normWR, normW]') do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end - w1L = gL_x(j, k, l, 1) w2L = gL_x(j, k, l, 2) w3L = 0._wp @@ -124,30 +111,25 @@ contains @:compute_capillary_stress_tensor() do i = 1, num_dims + flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(1, i) - flux_src_vf(momxb + i - 1)%sf(j, k, l) = & - flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(1, i) - - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + & - Omega(1, i)*vSrc_rsx_vf(j, k, l, i) - + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(1, i)*vSrc_rsx_vf(j, k, & + & l, i) end do - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + & - sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsx_vf(j, k, l, 1) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + sigma*c_divs(num_dims + 1)%sf(j, k, & + & l)*vSrc_rsx_vf(j, k, l, 1) end if end do end do end do $:END_GPU_PARALLEL_LOOP() - - elseif (id == 2) then + else if (id == 2) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 $:GPU_PARALLEL_LOOP(collapse=3, private='[Omega, w1L, w2L, w3L, w1R, w2R, w3R, w1, w2, w3, normWL, normWR, normW]') do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end - w1L = gL_y(k, j, l, 1) w2L = gL_y(k, j, l, 2) w3L = 0._wp @@ -170,32 +152,26 @@ contains @:compute_capillary_stress_tensor() do i = 1, num_dims + flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(2, i) - flux_src_vf(momxb + i - 1)%sf(j, k, l) = & - flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(2, i) - - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + & - Omega(2, i)*vSrc_rsy_vf(k, j, l, i) - + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(2, i)*vSrc_rsy_vf(k, & + & j, l, i) end do - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + & - sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsy_vf(k, j, l, 2) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & + & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsy_vf(k, j, l, 2) end if end do end do end do $:END_GPU_PARALLEL_LOOP() #:endif - - elseif (id == 3) then + else if (id == 3) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - $:GPU_PARALLEL_LOOP(collapse=3, private='[Omega, w1L, w2L, w3L, w1R, w2R, w3R, w1, w2, w3, normWL, normWR, normW]') do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end - w1L = gL_z(l, k, j, 1) w2L = gL_z(l, k, j, 2) w3L = 0._wp @@ -218,17 +194,14 @@ contains @:compute_capillary_stress_tensor() do i = 1, num_dims + flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(3, i) - flux_src_vf(momxb + i - 1)%sf(j, k, l) = & - flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(3, i) - - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + & - Omega(3, i)*vSrc_rsz_vf(l, k, j, i) - + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(3, i)*vSrc_rsz_vf(l, & + & k, j, i) end do - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + & - sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsz_vf(l, k, j, 3) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & + & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsz_vf(l, k, j, 3) end if end do end do @@ -236,17 +209,13 @@ contains $:END_GPU_PARALLEL_LOOP() #:endif end if - end subroutine s_compute_capillary_source_flux - !> @brief Computes color-function gradients and their norms, then reconstructs them at cell boundaries. impure subroutine s_get_capillary(q_prim_vf, bc_type) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - - type(int_bounds_info) :: isx, isy, isz - integer :: j, k, l, i + type(int_bounds_info) :: isx, isy, isz + integer :: j, k, l, i isx%beg = -1; isy%beg = 0; isz%beg = 0 @@ -259,8 +228,8 @@ contains do l = 0, p do k = 0, n do j = 0, m - c_divs(1)%sf(j, k, l) = 1._wp/(x_cc(j + 1) - x_cc(j - 1))* & - (q_prim_vf(c_idx)%sf(j + 1, k, l) - q_prim_vf(c_idx)%sf(j - 1, k, l)) + c_divs(1)%sf(j, k, l) = 1._wp/(x_cc(j + 1) - x_cc(j - 1))*(q_prim_vf(c_idx)%sf(j + 1, k, & + & l) - q_prim_vf(c_idx)%sf(j - 1, k, l)) end do end do end do @@ -270,8 +239,8 @@ contains do l = 0, p do k = 0, n do j = 0, m - c_divs(2)%sf(j, k, l) = 1._wp/(y_cc(k + 1) - y_cc(k - 1))* & - (q_prim_vf(c_idx)%sf(j, k + 1, l) - q_prim_vf(c_idx)%sf(j, k - 1, l)) + c_divs(2)%sf(j, k, l) = 1._wp/(y_cc(k + 1) - y_cc(k - 1))*(q_prim_vf(c_idx)%sf(j, k + 1, & + & l) - q_prim_vf(c_idx)%sf(j, k - 1, l)) end do end do end do @@ -282,8 +251,8 @@ contains do l = 0, p do k = 0, n do j = 0, m - c_divs(3)%sf(j, k, l) = 1._wp/(z_cc(l + 1) - z_cc(l - 1))* & - (q_prim_vf(c_idx)%sf(j, k, l + 1) - q_prim_vf(c_idx)%sf(j, k, l - 1)) + c_divs(3)%sf(j, k, l) = 1._wp/(z_cc(l + 1) - z_cc(l - 1))*(q_prim_vf(c_idx)%sf(j, k, & + & l + 1) - q_prim_vf(c_idx)%sf(j, k, l - 1)) end do end do end do @@ -297,14 +266,11 @@ contains c_divs(num_dims + 1)%sf(j, k, l) = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims - c_divs(num_dims + 1)%sf(j, k, l) = & - c_divs(num_dims + 1)%sf(j, k, l) + & - c_divs(i)%sf(j, k, l)**2._wp + c_divs(num_dims + 1)%sf(j, k, l) = c_divs(num_dims + 1)%sf(j, k, l) + c_divs(i)%sf(j, k, l)**2._wp end do - !c_divs(num_dims + 1)%sf(j, k, l) = & - !sqrt(c_divs(num_dims + 1)%sf(j, k, l)) - c_divs(num_dims + 1)%sf(j, k, l) = & - sqrt(real(c_divs(num_dims + 1)%sf(j, k, l), kind=wp)) + ! c_divs(num_dims + 1)%sf(j, k, l) = & + ! sqrt(c_divs(num_dims + 1)%sf(j, k, l)) + c_divs(num_dims + 1)%sf(j, k, l) = sqrt(real(c_divs(num_dims + 1)%sf(j, k, l), kind=wp)) end do end do end do @@ -318,21 +284,15 @@ contains do i = 1, num_dims call s_reconstruct_cell_boundary_values_capillary(c_divs, gL_x, gL_y, gL_z, gR_x, gR_y, gR_z, i) end do - end subroutine s_get_capillary - !> @brief Reconstructs left and right cell-boundary values of capillary (color-gradient) variables using WENO or MUSCL. - subroutine s_reconstruct_cell_boundary_values_capillary(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & - norm_dir) - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - + subroutine s_reconstruct_cell_boundary_values_capillary(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(out) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(out) :: vR_x, vR_y, vR_z - integer, intent(in) :: norm_dir - - integer :: recon_dir !< Coordinate direction of the reconstruction - - integer :: i, j, k, l + integer, intent(in) :: norm_dir + integer :: recon_dir !< Coordinate direction of the reconstruction + integer :: i, j, k, l #:for SCHEME, TYPE in [('weno', 'WENO_TYPE'),('muscl', 'MUSCL_TYPE')] if (recon_type == ${TYPE}$ .or. dummy) then @@ -342,20 +302,17 @@ contains is1 = idwbuff(1); is2 = idwbuff(2); is3 = idwbuff(3) recon_dir = 1; is1%beg = is1%beg + ${SCHEME}$_polyn is1%end = is1%end - ${SCHEME}$_polyn - - elseif (norm_dir == 2) then + else if (norm_dir == 2) then is1 = idwbuff(2); is2 = idwbuff(1); is3 = idwbuff(3) recon_dir = 2; is1%beg = is1%beg + ${SCHEME}$_polyn is1%end = is1%end - ${SCHEME}$_polyn - else is1 = idwbuff(3); is2 = idwbuff(2); is3 = idwbuff(1) recon_dir = 3; is1%beg = is1%beg + ${SCHEME}$_polyn is1%end = is1%end - ${SCHEME}$_polyn - end if - $:GPU_UPDATE(device='[is1,is2,is3,iv]') + $:GPU_UPDATE(device='[is1, is2, is3, iv]') end if #:endfor @@ -399,9 +356,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_reconstruct_cell_boundary_values_capillary - !> @brief Deallocates the color-gradient divergence and reconstructed boundary arrays for surface tension. impure subroutine s_finalize_surface_tension_module integer :: j @@ -418,7 +373,5 @@ contains if (p > 0) then @:DEALLOCATE(gL_z, gR_z) end if - end subroutine s_finalize_surface_tension_module - end module m_surface_tension diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 1e39da0926..3aeaf17eaf 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -7,7 +7,6 @@ !> @brief Total-variation-diminishing (TVD) Runge--Kutta time integrators (1st-, 2nd-, and 3rd-order SSP) module m_time_steppers - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -55,46 +54,41 @@ module m_time_steppers type(scalar_field), allocatable, dimension(:) :: rhs_vf !< !! Cell-average RHS variables at the current time-stage - type(integer_field), allocatable, dimension(:, :) :: bc_type !< + type(integer_field), allocatable, dimension(:,:) :: bc_type !< !! Boundary condition identifiers type(vector_field), allocatable, dimension(:) :: q_prim_ts1, q_prim_ts2 !< !! Cell-average primitive variables at consecutive TIMESTEPS - real(wp), allocatable, dimension(:, :, :, :, :) :: rhs_pb - - type(scalar_field) :: q_T_sf !< + real(wp), allocatable, dimension(:,:,:,:,:) :: rhs_pb + type(scalar_field) :: q_T_sf !< !! Cell-average temperature variables at the current time-stage - real(wp), allocatable, dimension(:, :, :, :, :) :: rhs_mv - - real(wp), allocatable, dimension(:, :, :) :: max_dt - - integer, private :: num_ts !< + real(wp), allocatable, dimension(:,:,:,:,:) :: rhs_mv + real(wp), allocatable, dimension(:,:,:) :: max_dt + integer, private :: num_ts !< !! Number of time stages in the time-stepping scheme - integer :: stor !< storage index - real(wp), allocatable, dimension(:, :) :: rk_coef - integer, private :: num_probe_ts + integer :: stor !< storage index + real(wp), allocatable, dimension(:,:) :: rk_coef + integer, private :: num_probe_ts - $:GPU_DECLARE(create='[q_cons_ts,q_prim_vf,q_T_sf,rhs_vf,q_prim_ts1,q_prim_ts2,rhs_mv,rhs_pb,max_dt,rk_coef,stor,bc_type]') + $:GPU_DECLARE(create='[q_cons_ts, q_prim_vf, q_T_sf, rhs_vf, q_prim_ts1, q_prim_ts2, rhs_mv, rhs_pb, max_dt, rk_coef, stor, bc_type]') -!> @cond + !> @cond #if defined(__NVCOMPILER_GPU_UNIFIED_MEM) - real(stp), allocatable, dimension(:, :, :, :), pinned, target :: q_cons_ts_pool_host + real(stp), allocatable, dimension(:,:,:,:), pinned, target :: q_cons_ts_pool_host #elif defined(FRONTIER_UNIFIED) - real(stp), pointer, contiguous, dimension(:, :, :, :) :: q_cons_ts_pool_host, q_cons_ts_pool_device - integer(kind=8) :: pool_dims(4), pool_starts(4) - integer(kind=8) :: pool_size - type(c_ptr) :: cptr_host, cptr_device + real(stp), pointer, contiguous, dimension(:,:,:,:) :: q_cons_ts_pool_host, q_cons_ts_pool_device + integer(kind=8) :: pool_dims(4), pool_starts(4) + integer(kind=8) :: pool_size + type(c_ptr) :: cptr_host, cptr_device #endif -!> @endcond - + !> @endcond contains - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_time_steppers_module #ifdef FRONTIER_UNIFIED use hipfort @@ -109,7 +103,7 @@ contains ! Setting number of time-stages for selected time-stepping scheme if (time_stepper == 1) then num_ts = 1 - elseif (any(time_stepper == (/2, 3/))) then + else if (any(time_stepper == (/2, 3/))) then num_ts = 2 end if @@ -126,32 +120,25 @@ contains @:PREFER_GPU(q_cons_ts(i)%vf) end do -!> @cond + !> @cond #if defined(__NVCOMPILER_GPU_UNIFIED_MEM) if (num_ts == 2 .and. nv_uvm_out_of_core) then ! host allocation for q_cons_ts(2)%vf(j)%sf for all j - allocate (q_cons_ts_pool_host(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end, & - 1:sys_size)) + allocate (q_cons_ts_pool_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) end if do j = 1, sys_size ! q_cons_ts(1) lives on the device - @:ALLOCATE(q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(q_cons_ts(1)%vf(j)%sf) if (num_ts == 2) then if (nv_uvm_out_of_core) then ! q_cons_ts(2) lives on the host - q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:, :, :, j) + q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) else - @:ALLOCATE(q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(q_cons_ts(2)%vf(j)%sf) end if end if @@ -170,7 +157,8 @@ contains pool_dims(4) = sys_size pool_starts(4) = 1 #ifdef MFC_MIXED_PRECISION - pool_size = 1_8*(idwbuff(1)%end - idwbuff(1)%beg + 1)*(idwbuff(2)%end - idwbuff(2)%beg + 1)*(idwbuff(3)%end - idwbuff(3)%beg + 1)*sys_size + pool_size = 1_8*(idwbuff(1)%end - idwbuff(1)%beg + 1)*(idwbuff(2)%end - idwbuff(2)%beg + 1)*(idwbuff(3)%end - idwbuff(3) & + & %beg + 1)*sys_size call hipCheck(hipMalloc_(cptr_device, pool_size*2_8)) call c_f_pointer(cptr_device, q_cons_ts_pool_device, shape=pool_dims) q_cons_ts_pool_device(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:) => q_cons_ts_pool_device @@ -191,21 +179,20 @@ contains if (num_ts == 2) then call hipCheck(hipMallocManaged(q_cons_ts_pool_host, dims8=pool_dims, lbounds8=pool_starts, flags=hipMemAttachGlobal)) #if defined(MFC_OpenMP) - call hipCheck(hipMemAdvise(c_loc(q_cons_ts_pool_host), c_sizeof(q_cons_ts_pool_host), hipMemAdviseSetPreferredLocation, -1)) + call hipCheck(hipMemAdvise(c_loc(q_cons_ts_pool_host), c_sizeof(q_cons_ts_pool_host), & + & hipMemAdviseSetPreferredLocation, -1)) #endif end if #endif do j = 1, sys_size ! q_cons_ts(1) lives on the device - q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_device(:, :, :, j) + q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_device(:,:,:, j) if (num_ts == 2) then ! q_cons_ts(2) lives on the host - q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:, :, :, j) + q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) end if end do @@ -216,18 +203,16 @@ contains end do end do #else -!> @endcond + !> @endcond do i = 1, num_ts do j = 1, sys_size - @:ALLOCATE(q_cons_ts(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_cons_ts(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_cons_ts(i)) end do -!> @cond + !> @cond #endif -!> @endcond + !> @endcond ! Allocating the cell-average primitive ts variables if (probe_wrt) then @@ -239,9 +224,7 @@ contains do i = 1, num_probe_ts do j = 1, sys_size - @:ALLOCATE(q_prim_ts1(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_ts1(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_prim_ts1(i)) end do @@ -254,9 +237,7 @@ contains do i = 1, num_probe_ts do j = 1, sys_size - @:ALLOCATE(q_prim_ts2(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_ts2(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_prim_ts2(i)) end do @@ -267,129 +248,93 @@ contains if (.not. igr) then do i = 1, adv_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do if (bubbles_euler) then do i = bub_idx%beg, bub_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do if (adv_n) then - @:ALLOCATE(q_prim_vf(n_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(n_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(n_idx)) end if end if if (mhd) then do i = B_idx%beg, B_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (elasticity) then do i = stress_idx%beg, stress_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (hyperelasticity) then do i = xibeg, xiend + 1 - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (cont_damage) then - @:ALLOCATE(q_prim_vf(damage_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(damage_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(damage_idx)) end if if (hyper_cleaning) then - @:ALLOCATE(q_prim_vf(psi_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(psi_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(psi_idx)) end if if (model_eqns == 3) then do i = internalEnergies_idx%beg, internalEnergies_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (surface_tension) then - @:ALLOCATE(q_prim_vf(c_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(c_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(c_idx)) end if if (chemistry) then do i = chemxb, chemxe - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do - @:ALLOCATE(q_T_sf%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_T_sf%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_T_sf) end if end if @:ALLOCATE(pb_ts(1:2)) - !Initialize bubble variables pb and mv at all quadrature nodes for all R0 bins + ! Initialize bubble variables pb and mv at all quadrature nodes for all R0 bins if (qbmm .and. (.not. polytropic)) then - @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(1)) - @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(2)) - @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) else if (qbmm .and. polytropic) then - @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, & - idwbuff(2)%beg:idwbuff(2)%beg + 1, & - idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(1)) - @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, & - idwbuff(2)%beg:idwbuff(2)%beg + 1, & - idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(2)) - @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%beg + 1, & - idwbuff(2)%beg:idwbuff(2)%beg + 1, & - idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) else @:ALLOCATE(pb_ts(1)%sf(0,0,0,0,0)) @:ACC_SETUP_SFs(pb_ts(1)) @@ -403,34 +348,21 @@ contains @:ALLOCATE(mv_ts(1:2)) if (qbmm .and. (.not. polytropic)) then - @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(1)) - @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(2)) - @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%end, & - idwbuff(2)%beg:idwbuff(2)%end, & - idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) - + @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) else if (qbmm .and. polytropic) then - @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, & - idwbuff(2)%beg:idwbuff(2)%beg + 1, & - idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(1)) - @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, & - idwbuff(2)%beg:idwbuff(2)%beg + 1, & - idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(2)) - @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%beg + 1, & - idwbuff(2)%beg:idwbuff(2)%beg + 1, & - idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) else @:ALLOCATE(mv_ts(1)%sf(0,0,0,0,0)) @:ACC_SETUP_SFs(mv_ts(1)) @@ -505,34 +437,31 @@ contains end if ! TVD RK coefficients - @:ALLOCATE (rk_coef(time_stepper, 4)) + @:ALLOCATE(rk_coef(time_stepper, 4)) if (time_stepper == 1) then - rk_coef(1, :) = (/1._wp, 0._wp, 1._wp, 1._wp/) + rk_coef(1,:) = (/1._wp, 0._wp, 1._wp, 1._wp/) else if (time_stepper == 2) then - rk_coef(1, :) = (/1._wp, 0._wp, 1._wp, 1._wp/) - rk_coef(2, :) = (/1._wp, 1._wp, 1._wp, 2._wp/) + rk_coef(1,:) = (/1._wp, 0._wp, 1._wp, 1._wp/) + rk_coef(2,:) = (/1._wp, 1._wp, 1._wp, 2._wp/) else if (time_stepper == 3) then - rk_coef(1, :) = (/1._wp, 0._wp, 1._wp, 1._wp/) - rk_coef(2, :) = (/1._wp, 3._wp, 1._wp, 4._wp/) - rk_coef(3, :) = (/2._wp, 1._wp, 2._wp, 3._wp/) + rk_coef(1,:) = (/1._wp, 0._wp, 1._wp, 1._wp/) + rk_coef(2,:) = (/1._wp, 3._wp, 1._wp, 4._wp/) + rk_coef(3,:) = (/2._wp, 1._wp, 2._wp, 3._wp/) end if $:GPU_UPDATE(device='[rk_coef, stor]') end if - end subroutine s_initialize_time_steppers_module - !> @brief Advances the solution one full step using a TVD Runge-Kutta time integrator. impure subroutine s_tvd_rk(t_step, time_avg, nstage) #ifdef _CRAYFTN - !DIR$ OPTIMIZE (-haggress) + ! DIR$ OPTIMIZE (-haggress) #endif - integer, intent(in) :: t_step + integer, intent(in) :: t_step real(wp), intent(inout) :: time_avg - integer, intent(in) :: nstage - - integer :: i, j, k, l, q, s !< Generic loop iterator - real(wp) :: start, finish - integer :: dest + integer, intent(in) :: nstage + integer :: i, j, k, l, q, s !< Generic loop iterator + real(wp) :: start, finish + integer :: dest call cpu_time(start) call nvtxStartRange("TIMESTEP") @@ -541,7 +470,8 @@ contains if (adap_dt) call s_adaptive_dt_bubble(1) do s = 1, nstage - call s_compute_rhs(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_ts(1)%sf, rhs_pb, mv_ts(1)%sf, rhs_mv, t_step, time_avg, s) + call s_compute_rhs(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_ts(1)%sf, rhs_pb, mv_ts(1)%sf, rhs_mv, & + & t_step, time_avg, s) if (s == 1) then if (run_time_info) then @@ -572,26 +502,23 @@ contains do k = 0, n do j = 0, m if (s == 1 .and. nstage > 1) then - q_cons_ts(stor)%vf(i)%sf(j, k, l) = & - q_cons_ts(1)%vf(i)%sf(j, k, l) + q_cons_ts(stor)%vf(i)%sf(j, k, l) = q_cons_ts(1)%vf(i)%sf(j, k, l) end if if (igr) then - q_cons_ts(1)%vf(i)%sf(j, k, l) = & - (rk_coef(s, 1)*q_cons_ts(1)%vf(i)%sf(j, k, l) & - + rk_coef(s, 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) & - + rk_coef(s, 3)*rhs_vf(i)%sf(j, k, l))/rk_coef(s, 4) + q_cons_ts(1)%vf(i)%sf(j, k, l) = (rk_coef(s, 1)*q_cons_ts(1)%vf(i)%sf(j, k, l) + rk_coef(s, & + & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*rhs_vf(i)%sf(j, k, & + & l))/rk_coef(s, 4) else - q_cons_ts(1)%vf(i)%sf(j, k, l) = & - (rk_coef(s, 1)*q_cons_ts(1)%vf(i)%sf(j, k, l) & - + rk_coef(s, 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) & - + rk_coef(s, 3)*dt*rhs_vf(i)%sf(j, k, l))/rk_coef(s, 4) + q_cons_ts(1)%vf(i)%sf(j, k, l) = (rk_coef(s, 1)*q_cons_ts(1)%vf(i)%sf(j, k, l) + rk_coef(s, & + & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*dt*rhs_vf(i)%sf(j, k, & + & l))/rk_coef(s, 4) end if end do end do end do end do $:END_GPU_PARALLEL_LOOP() - !Evolve pb and mv for non-polytropic qbmm + ! Evolve pb and mv for non-polytropic qbmm if (qbmm .and. (.not. polytropic)) then $:GPU_PARALLEL_LOOP(collapse=5) do i = 1, nb @@ -600,19 +527,13 @@ contains do j = 0, m do q = 1, nnode if (s == 1 .and. nstage > 1) then - pb_ts(stor)%sf(j, k, l, q, i) = & - pb_ts(1)%sf(j, k, l, q, i) - mv_ts(stor)%sf(j, k, l, q, i) = & - mv_ts(1)%sf(j, k, l, q, i) + pb_ts(stor)%sf(j, k, l, q, i) = pb_ts(1)%sf(j, k, l, q, i) + mv_ts(stor)%sf(j, k, l, q, i) = mv_ts(1)%sf(j, k, l, q, i) end if - pb_ts(1)%sf(j, k, l, q, i) = & - (rk_coef(s, 1)*pb_ts(1)%sf(j, k, l, q, i) & - + rk_coef(s, 2)*pb_ts(stor)%sf(j, k, l, q, i) & - + rk_coef(s, 3)*dt*rhs_pb(j, k, l, q, i))/rk_coef(s, 4) - mv_ts(1)%sf(j, k, l, q, i) = & - (rk_coef(s, 1)*mv_ts(1)%sf(j, k, l, q, i) & - + rk_coef(s, 2)*mv_ts(stor)%sf(j, k, l, q, i) & - + rk_coef(s, 3)*dt*rhs_mv(j, k, l, q, i))/rk_coef(s, 4) + pb_ts(1)%sf(j, k, l, q, i) = (rk_coef(s, 1)*pb_ts(1)%sf(j, k, l, q, i) + rk_coef(s, & + & 2)*pb_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_pb(j, k, l, q, i))/rk_coef(s, 4) + mv_ts(1)%sf(j, k, l, q, i) = (rk_coef(s, 1)*mv_ts(1)%sf(j, k, l, q, i) + rk_coef(s, & + & 2)*mv_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_mv(j, k, l, q, i))/rk_coef(s, 4) end do end do end do @@ -652,7 +573,6 @@ contains call s_ibm_correct_state(q_cons_ts(1)%vf, q_prim_vf) end if end if - end do if (moving_immersed_boundary_flag) call s_wrap_periodic_ibs() @@ -670,30 +590,19 @@ contains else wall_time_avg = 0._wp end if - end subroutine s_tvd_rk - !> Bubble source part in Strang operator splitting scheme !! @param stage Current time-stage impure subroutine s_adaptive_dt_bubble(stage) - integer, intent(in) :: stage + type(vector_field) :: gm_alpha_qp - type(vector_field) :: gm_alpha_qp - - call s_convert_conservative_to_primitive_variables( & - q_cons_ts(1)%vf, & - q_T_sf, & - q_prim_vf, & - idwint) + call s_convert_conservative_to_primitive_variables(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, idwint) if (bubbles_euler) then - call s_compute_bubble_EE_source(q_cons_ts(1)%vf, q_prim_vf, rhs_vf, divu) call s_comp_alpha_from_n(q_cons_ts(1)%vf) - - elseif (bubbles_lagrange) then - + else if (bubbles_lagrange) then call s_populate_variables_buffers(bc_type, q_prim_vf, pb_ts(1)%sf, mv_ts(1)%sf) call s_compute_bubble_EL_dynamics(q_prim_vf, stage) call s_transfer_data_to_tmp() @@ -701,46 +610,37 @@ contains if (stage == 3) then if (lag_params%write_bubbles_stats) call s_calculate_lag_bubble_stats() if (lag_params%write_bubbles) then - $:GPU_UPDATE(host='[gas_p,gas_mv,intfc_rad,intfc_vel]') + $:GPU_UPDATE(host='[gas_p, gas_mv, intfc_rad, intfc_vel]') call s_write_lag_particles(mytime) end if call s_write_void_evol(mytime) end if - end if - end subroutine s_adaptive_dt_bubble - !> @brief Computes the global time step size from CFL stability constraints across all cells. impure subroutine s_compute_dt() - real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: vel !< Cell-avg. velocity real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction #:else - real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity + real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction #:endif - real(wp) :: vel_sum !< Cell-avg. velocity sum - real(wp) :: pres !< Cell-avg. pressure - real(wp) :: gamma !< Cell-avg. sp. heat ratio - real(wp) :: pi_inf !< Cell-avg. liquid stiffness function - real(wp) :: qv !< Cell-avg. fluid reference energy - real(wp) :: c !< Cell-avg. sound speed - real(wp) :: H !< Cell-avg. enthalpy + real(wp) :: vel_sum !< Cell-avg. velocity sum + real(wp) :: pres !< Cell-avg. pressure + real(wp) :: gamma !< Cell-avg. sp. heat ratio + real(wp) :: pi_inf !< Cell-avg. liquid stiffness function + real(wp) :: qv !< Cell-avg. fluid reference energy + real(wp) :: c !< Cell-avg. sound speed + real(wp) :: H !< Cell-avg. enthalpy real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers - type(vector_field) :: gm_alpha_qp - - real(wp) :: dt_local - integer :: j, k, l !< Generic loop iterators + type(vector_field) :: gm_alpha_qp + real(wp) :: dt_local + integer :: j, k, l !< Generic loop iterators if (.not. igr .or. dummy) then - call s_convert_conservative_to_primitive_variables( & - q_cons_ts(1)%vf, & - q_T_sf, & - q_prim_vf, & - idwint) + call s_convert_conservative_to_primitive_variables(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, idwint) end if $:GPU_PARALLEL_LOOP(collapse=3, private='[vel, alpha, Re, rho, vel_sum, pres, gamma, pi_inf, c, H, qv]') @@ -773,23 +673,17 @@ contains end if $:GPU_UPDATE(device='[dt]') - end subroutine s_compute_dt - - !> This subroutine applies the body forces source term at each - !! Runge-Kutta stage + !> This subroutine applies the body forces source term at each Runge-Kutta stage !! @param q_cons_vf Conservative variables !! @param q_prim_vf_in Primitive variables !! @param rhs_vf_in Right-hand side variables subroutine s_apply_bodyforces(q_cons_vf, q_prim_vf_in, rhs_vf_in, ldt) - type(scalar_field), dimension(1:sys_size), intent(inout) :: q_cons_vf - type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf_in + type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf_in type(scalar_field), dimension(1:sys_size), intent(inout) :: rhs_vf_in - - real(wp), intent(in) :: ldt !< local dt - - integer :: i, j, k, l + real(wp), intent(in) :: ldt !< local dt + integer :: i, j, k, l call nvtxStartRange("RHS-BODYFORCES") call s_compute_body_forces_rhs(q_prim_vf_in, q_cons_vf, rhs_vf_in) @@ -799,8 +693,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - q_cons_vf(i)%sf(j, k, l) = q_cons_vf(i)%sf(j, k, l) + & - ldt*rhs_vf_in(i)%sf(j, k, l) + q_cons_vf(i)%sf(j, k, l) = q_cons_vf(i)%sf(j, k, l) + ldt*rhs_vf_in(i)%sf(j, k, l) end do end do end do @@ -808,15 +701,12 @@ contains $:END_GPU_PARALLEL_LOOP() call nvtxEndRange - end subroutine s_apply_bodyforces - !> @brief Updates immersed boundary positions and velocities at the current Runge-Kutta stage. subroutine s_propagate_immersed_boundaries(s) - integer, intent(in) :: s - integer :: i - logical :: forces_computed + integer :: i + logical :: forces_computed call nvtxStartRange("PROPAGATE-IMMERSED-BOUNDARIES") @@ -834,7 +724,8 @@ contains if (patch_ib(i)%moving_ibm > 0) then patch_ib(i)%vel = (rk_coef(s, 1)*patch_ib(i)%step_vel + rk_coef(s, 2)*patch_ib(i)%vel)/rk_coef(s, 4) - patch_ib(i)%angular_vel = (rk_coef(s, 1)*patch_ib(i)%step_angular_vel + rk_coef(s, 2)*patch_ib(i)%angular_vel)/rk_coef(s, 4) + patch_ib(i)%angular_vel = (rk_coef(s, 1)*patch_ib(i)%step_angular_vel + rk_coef(s, & + & 2)*patch_ib(i)%angular_vel)/rk_coef(s, 4) if (patch_ib(i)%moving_ibm == 1) then ! plug in analytic velocities for 1-way coupling, if it exists @@ -850,35 +741,38 @@ contains patch_ib(i)%vel = patch_ib(i)%vel + rk_coef(s, 3)*dt*(patch_ib(i)%force/patch_ib(i)%mass)/rk_coef(s, 4) ! update the angular velocity with the torque value - patch_ib(i)%angular_vel = (patch_ib(i)%angular_vel*patch_ib(i)%moment) + (rk_coef(s, 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum - call s_compute_moment_of_inertia(i, patch_ib(i)%angular_vel) ! update the moment of inertia to be based on the direction of the angular momentum - patch_ib(i)%angular_vel = patch_ib(i)%angular_vel/patch_ib(i)%moment ! convert back to angular velocity with the new moment of inertia + patch_ib(i)%angular_vel = (patch_ib(i)%angular_vel*patch_ib(i)%moment) + (rk_coef(s, & + & 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum + call s_compute_moment_of_inertia(i, & + & patch_ib(i)%angular_vel) & + & ! update the moment of inertia to be based on the direction of the angular momentum + patch_ib(i)%angular_vel = patch_ib(i)%angular_vel/patch_ib(i) & + & %moment ! convert back to angular velocity with the new moment of inertia end if ! Update the angle of the IB - patch_ib(i)%angles = (rk_coef(s, 1)*patch_ib(i)%step_angles + rk_coef(s, 2)*patch_ib(i)%angles + rk_coef(s, 3)*patch_ib(i)%angular_vel*dt)/rk_coef(s, 4) + patch_ib(i)%angles = (rk_coef(s, 1)*patch_ib(i)%step_angles + rk_coef(s, 2)*patch_ib(i)%angles + rk_coef(s, & + & 3)*patch_ib(i)%angular_vel*dt)/rk_coef(s, 4) ! Update the position of the IB - patch_ib(i)%x_centroid = (rk_coef(s, 1)*patch_ib(i)%step_x_centroid + rk_coef(s, 2)*patch_ib(i)%x_centroid + rk_coef(s, 3)*patch_ib(i)%vel(1)*dt)/rk_coef(s, 4) - patch_ib(i)%y_centroid = (rk_coef(s, 1)*patch_ib(i)%step_y_centroid + rk_coef(s, 2)*patch_ib(i)%y_centroid + rk_coef(s, 3)*patch_ib(i)%vel(2)*dt)/rk_coef(s, 4) - patch_ib(i)%z_centroid = (rk_coef(s, 1)*patch_ib(i)%step_z_centroid + rk_coef(s, 2)*patch_ib(i)%z_centroid + rk_coef(s, 3)*patch_ib(i)%vel(3)*dt)/rk_coef(s, 4) + patch_ib(i)%x_centroid = (rk_coef(s, 1)*patch_ib(i)%step_x_centroid + rk_coef(s, & + & 2)*patch_ib(i)%x_centroid + rk_coef(s, 3)*patch_ib(i)%vel(1)*dt)/rk_coef(s, 4) + patch_ib(i)%y_centroid = (rk_coef(s, 1)*patch_ib(i)%step_y_centroid + rk_coef(s, & + & 2)*patch_ib(i)%y_centroid + rk_coef(s, 3)*patch_ib(i)%vel(2)*dt)/rk_coef(s, 4) + patch_ib(i)%z_centroid = (rk_coef(s, 1)*patch_ib(i)%step_z_centroid + rk_coef(s, & + & 2)*patch_ib(i)%z_centroid + rk_coef(s, 3)*patch_ib(i)%vel(3)*dt)/rk_coef(s, 4) end if end do call s_update_mib(num_ibs) call nvtxEndRange - end subroutine s_propagate_immersed_boundaries - - !> This subroutine saves the temporary q_prim_vf vector - !! into the q_prim_ts vector that is then used in p_main + !> This subroutine saves the temporary q_prim_vf vector into the q_prim_ts vector that is then used in p_main !! @param t_step current time-step subroutine s_time_step_cycling(t_step) - integer, intent(in) :: t_step - - integer :: i, j, k, l !< Generic loop iterator + integer :: i, j, k, l !< Generic loop iterator if (t_step == t_step_start) then $:GPU_PARALLEL_LOOP(collapse=4) @@ -892,7 +786,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - elseif (t_step == t_step_start + 1) then + else if (t_step == t_step_start + 1) then $:GPU_PARALLEL_LOOP(collapse=4) do i = 1, sys_size do l = 0, p @@ -904,7 +798,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - elseif (t_step == t_step_start + 2) then + else if (t_step == t_step_start + 2) then $:GPU_PARALLEL_LOOP(collapse=4) do i = 1, sys_size do l = 0, p @@ -916,7 +810,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - elseif (t_step == t_step_start + 3) then + else if (t_step == t_step_start + 3) then $:GPU_PARALLEL_LOOP(collapse=4) do i = 1, sys_size do l = 0, p @@ -944,9 +838,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_time_step_cycling - !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_time_steppers_module #ifdef FRONTIER_UNIFIED @@ -1073,7 +965,5 @@ contains if (proc_rank == 0 .and. ib_state_wrt) then call s_close_ib_state_file() end if - end subroutine s_finalize_time_steppers_module - end module m_time_steppers diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 9c6e4ad4d8..38ade6dcf8 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -6,7 +6,6 @@ !> @brief Computes viscous stress tensors and diffusive flux contributions for the Navier--Stokes equations module m_viscous - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -20,25 +19,19 @@ module m_viscous use m_finite_differences - private; public s_get_viscous, & - s_compute_viscous_stress_cylindrical_boundary, & - s_initialize_viscous_module, & - s_reconstruct_cell_boundary_values_visc_deriv, & - s_finalize_viscous_module, & - s_compute_viscous_stress_tensor + private; public s_get_viscous, s_compute_viscous_stress_cylindrical_boundary, s_initialize_viscous_module, & + & s_reconstruct_cell_boundary_values_visc_deriv, s_finalize_viscous_module, s_compute_viscous_stress_tensor type(int_bounds_info) :: iv type(int_bounds_info) :: is1_viscous, is2_viscous, is3_viscous - $:GPU_DECLARE(create='[is1_viscous,is2_viscous,is3_viscous,iv]') + $:GPU_DECLARE(create='[is1_viscous, is2_viscous, is3_viscous, iv]') - real(wp), allocatable, dimension(:, :) :: Res_viscous + real(wp), allocatable, dimension(:,:) :: Res_viscous $:GPU_DECLARE(create='[Res_viscous]') - contains !> @brief Allocates and populates the viscous Reynolds number arrays and transfers data to the GPU. impure subroutine s_initialize_viscous_module - integer :: i, j !< generic loop iterators @:ALLOCATE(Res_viscous(1:2, 1:Re_size_max)) @@ -48,11 +41,9 @@ contains Res_viscous(i, j) = fluid_pp(Re_idx(i, j))%Re(i) end do end do - $:GPU_UPDATE(device='[Res_viscous,Re_idx,Re_size]') - $:GPU_ENTER_DATA(copyin='[is1_viscous,is2_viscous,is3_viscous,iv]') - + $:GPU_UPDATE(device='[Res_viscous, Re_idx, Re_size]') + $:GPU_ENTER_DATA(copyin='[is1_viscous, is2_viscous, is3_viscous, iv]') end subroutine s_initialize_viscous_module - !> The purpose of this subroutine is to compute the viscous ! stress tensor for the cells directly next to the axis in ! cylindrical coordinates. This is necessary to avoid the @@ -62,22 +53,18 @@ contains ! @param grad_x_vf Cell-average primitive variable derivatives, x-dir ! @param grad_y_vf Cell-average primitive variable derivatives, y-dir ! @param grad_z_vf Cell-average primitive variable derivatives, z-dir - subroutine s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, grad_x_vf, grad_y_vf, grad_z_vf, & - tau_Re_vf, & - ix, iy, iz) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), dimension(num_dims), intent(in) :: grad_x_vf, grad_y_vf, grad_z_vf + subroutine s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, grad_x_vf, grad_y_vf, grad_z_vf, tau_Re_vf, ix, iy, iz) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(num_dims), intent(in) :: grad_x_vf, grad_y_vf, grad_z_vf type(scalar_field), dimension(1:sys_size), intent(inout) :: tau_Re_vf - type(int_bounds_info), intent(in) :: ix, iy, iz - - real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables - real(wp), dimension(2) :: Re_visc + type(int_bounds_info), intent(in) :: ix, iy, iz + real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables + real(wp), dimension(2) :: Re_visc #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha_visc, alpha_rho_visc + real(wp), dimension(3) :: alpha_visc, alpha_rho_visc real(wp), dimension(3, 3) :: tau_Re #:else - real(wp), dimension(num_fluids) :: alpha_visc, alpha_rho_visc + real(wp), dimension(num_fluids) :: alpha_visc, alpha_rho_visc real(wp), dimension(num_dims, num_dims) :: tau_Re #:endif @@ -85,7 +72,7 @@ contains is1_viscous = ix; is2_viscous = iy; is3_viscous = iz - $:GPU_UPDATE(device='[is1_viscous,is2_viscous,is3_viscous]') + $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous]') $:GPU_PARALLEL_LOOP(collapse=3) do l = is3_viscous%beg, is3_viscous%end @@ -101,12 +88,12 @@ contains $:END_GPU_PARALLEL_LOOP() #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (shear_stress) then ! Shear stresses - $:GPU_PARALLEL_LOOP(collapse=3, private='[i,j,k,l,q,rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') + if (shear_stress) then ! Shear stresses + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & + & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end do k = -1, 1 do j = is1_viscous%beg, is1_viscous%end - $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) @@ -157,7 +144,6 @@ contains end do alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - end if $:GPU_LOOP(parallelism='[seq]') @@ -175,33 +161,24 @@ contains if (Re_size(i) > 0) Re_visc(i) = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, Re_size(i) - Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) & - + Re_visc(i) + Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) + Re_visc(i) end do Re_visc(i) = 1._wp/max(Re_visc(i), sgm_eps) - end do end if end if - tau_Re(2, 1) = (grad_y_vf(1)%sf(j, k, l) + & - grad_x_vf(2)%sf(j, k, l))/ & - Re_visc(1) + tau_Re(2, 1) = (grad_y_vf(1)%sf(j, k, l) + grad_x_vf(2)%sf(j, k, l))/Re_visc(1) - tau_Re(2, 2) = (4._wp*grad_y_vf(2)%sf(j, k, l) & - - 2._wp*grad_x_vf(1)%sf(j, k, l) & - - 2._wp*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/ & - (3._wp*Re_visc(1)) + tau_Re(2, 2) = (4._wp*grad_y_vf(2)%sf(j, k, l) - 2._wp*grad_x_vf(1)%sf(j, k, & + & l) - 2._wp*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/(3._wp*Re_visc(1)) $:GPU_LOOP(parallelism='[seq]') do i = 1, 2 - tau_Re_vf(contxe + i)%sf(j, k, l) = & - tau_Re_vf(contxe + i)%sf(j, k, l) - & - tau_Re(2, i) + tau_Re_vf(contxe + i)%sf(j, k, l) = tau_Re_vf(contxe + i)%sf(j, k, l) - tau_Re(2, i) - tau_Re_vf(E_idx)%sf(j, k, l) = & - tau_Re_vf(E_idx)%sf(j, k, l) - & - q_prim_vf(contxe + i)%sf(j, k, l)*tau_Re(2, i) + tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(contxe + i)%sf(j, k, & + & l)*tau_Re(2, i) end do end do end do @@ -211,12 +188,12 @@ contains #:endif #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (bulk_stress) then ! Bulk stresses - $:GPU_PARALLEL_LOOP(collapse=3, private='[i,j,k,l,q,rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') + if (bulk_stress) then ! Bulk stresses + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & + & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end do k = -1, 1 do j = is1_viscous%beg, is1_viscous%end - $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) @@ -267,7 +244,6 @@ contains end do alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - end if $:GPU_LOOP(parallelism='[seq]') @@ -285,29 +261,21 @@ contains if (Re_size(i) > 0) Re_visc(i) = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, Re_size(i) - Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) & - + Re_visc(i) + Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) + Re_visc(i) end do Re_visc(i) = 1._wp/max(Re_visc(i), sgm_eps) - end do end if end if - tau_Re(2, 2) = (grad_x_vf(1)%sf(j, k, l) + & - grad_y_vf(2)%sf(j, k, l) + & - q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/ & - Re_visc(2) - - tau_Re_vf(momxb + 1)%sf(j, k, l) = & - tau_Re_vf(momxb + 1)%sf(j, k, l) - & - tau_Re(2, 2) + tau_Re(2, 2) = (grad_x_vf(1)%sf(j, k, l) + grad_y_vf(2)%sf(j, k, l) + q_prim_vf(momxb + 1)%sf(j, k, & + & l)/y_cc(k))/Re_visc(2) - tau_Re_vf(E_idx)%sf(j, k, l) = & - tau_Re_vf(E_idx)%sf(j, k, l) - & - q_prim_vf(momxb + 1)%sf(j, k, l)*tau_Re(2, 2) + tau_Re_vf(momxb + 1)%sf(j, k, l) = tau_Re_vf(momxb + 1)%sf(j, k, l) - tau_Re(2, 2) + tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(momxb + 1)%sf(j, k, & + & l)*tau_Re(2, 2) end do end do end do @@ -317,13 +285,12 @@ contains if (p == 0) return #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - - if (shear_stress) then ! Shear stresses - $:GPU_PARALLEL_LOOP(collapse=3, private='[i,j,k,l,q,rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') + if (shear_stress) then ! Shear stresses + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & + & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end do k = -1, 1 do j = is1_viscous%beg, is1_viscous%end - $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) @@ -374,7 +341,6 @@ contains end do alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - end if $:GPU_LOOP(parallelism='[seq]') @@ -392,47 +358,38 @@ contains if (Re_size(i) > 0) Re_visc(i) = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, Re_size(i) - Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) & - + Re_visc(i) + Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) + Re_visc(i) end do Re_visc(i) = 1._wp/max(Re_visc(i), sgm_eps) - end do end if end if - tau_Re(2, 2) = -(2._wp/3._wp)*grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & - Re_visc(1) + tau_Re(2, 2) = -(2._wp/3._wp)*grad_z_vf(3)%sf(j, k, l)/y_cc(k)/Re_visc(1) - tau_Re(2, 3) = ((grad_z_vf(2)%sf(j, k, l) - & - q_prim_vf(momxe)%sf(j, k, l))/ & - y_cc(k) + grad_y_vf(3)%sf(j, k, l))/ & - Re_visc(1) + tau_Re(2, 3) = ((grad_z_vf(2)%sf(j, k, l) - q_prim_vf(momxe)%sf(j, k, & + & l))/y_cc(k) + grad_y_vf(3)%sf(j, k, l))/Re_visc(1) $:GPU_LOOP(parallelism='[seq]') do i = 2, 3 - tau_Re_vf(contxe + i)%sf(j, k, l) = & - tau_Re_vf(contxe + i)%sf(j, k, l) - & - tau_Re(2, i) + tau_Re_vf(contxe + i)%sf(j, k, l) = tau_Re_vf(contxe + i)%sf(j, k, l) - tau_Re(2, i) - tau_Re_vf(E_idx)%sf(j, k, l) = & - tau_Re_vf(E_idx)%sf(j, k, l) - & - q_prim_vf(contxe + i)%sf(j, k, l)*tau_Re(2, i) + tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(contxe + i)%sf(j, k, & + & l)*tau_Re(2, i) end do - end do end do end do $:END_GPU_PARALLEL_LOOP() end if - if (bulk_stress) then ! Bulk stresses - $:GPU_PARALLEL_LOOP(collapse=3, private='[i,j,k,l,q,rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') + if (bulk_stress) then ! Bulk stresses + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & + & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end do k = -1, 1 do j = is1_viscous%beg, is1_viscous%end - $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids alpha_rho_visc(i) = q_prim_vf(i)%sf(j, k, l) @@ -483,7 +440,6 @@ contains end do alpha_visc = alpha_visc/max(alpha_visc_sum, sgm_eps) - end if $:GPU_LOOP(parallelism='[seq]') @@ -501,27 +457,20 @@ contains if (Re_size(i) > 0) Re_visc(i) = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, Re_size(i) - Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) & - + Re_visc(i) + Re_visc(i) = alpha_visc(Re_idx(i, q))/Res_viscous(i, q) + Re_visc(i) end do Re_visc(i) = 1._wp/max(Re_visc(i), sgm_eps) - end do end if end if - tau_Re(2, 2) = grad_z_vf(3)%sf(j, k, l)/y_cc(k)/ & - Re_visc(2) - - tau_Re_vf(momxb + 1)%sf(j, k, l) = & - tau_Re_vf(momxb + 1)%sf(j, k, l) - & - tau_Re(2, 2) + tau_Re(2, 2) = grad_z_vf(3)%sf(j, k, l)/y_cc(k)/Re_visc(2) - tau_Re_vf(E_idx)%sf(j, k, l) = & - tau_Re_vf(E_idx)%sf(j, k, l) - & - q_prim_vf(momxb + 1)%sf(j, k, l)*tau_Re(2, 2) + tau_Re_vf(momxb + 1)%sf(j, k, l) = tau_Re_vf(momxb + 1)%sf(j, k, l) - tau_Re(2, 2) + tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(momxb + 1)%sf(j, k, & + & l)*tau_Re(2, 2) end do end do end do @@ -529,70 +478,52 @@ contains end if #:endif end subroutine s_compute_viscous_stress_cylindrical_boundary - - !> Computes viscous terms - !! @param qL_prim_rsx_vf Left reconstructed primitive variables in x - !! @param qL_prim_rsy_vf Left reconstructed primitive variables in y - !! @param qL_prim_rsz_vf Left reconstructed primitive variables in z - !! @param dqL_prim_dx_n Left primitive x-derivative - !! @param dqL_prim_dy_n Left primitive y-derivative - !! @param dqL_prim_dz_n Left primitive z-derivative - !! @param qL_prim Left cell-boundary primitive variables - !! @param qR_prim_rsx_vf Right reconstructed primitive variables in x - !! @param qR_prim_rsy_vf Right reconstructed primitive variables in y - !! @param qR_prim_rsz_vf Right reconstructed primitive variables in z - !! @param dqR_prim_dx_n Right primitive x-derivative - !! @param dqR_prim_dy_n Right primitive y-derivative - !! @param dqR_prim_dz_n Right primitive z-derivative - !! @param qR_prim Right cell-boundary primitive variables - !! @param q_prim_qp Cell-averaged primitive variables - !! @param dq_prim_dx_qp Cell-averaged primitive x-derivative - !! @param dq_prim_dy_qp Cell-averaged primitive y-derivative - !! @param dq_prim_dz_qp Cell-averaged primitive z-derivative - !! @param ix Index bounds in the x-direction - !! @param iy Index bounds in the y-direction - !! @param iz Index bounds in the z-direction - subroutine s_get_viscous(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & - dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, & - qL_prim, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & - dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, & - qR_prim, & - q_prim_qp, & - dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, & - 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, & - qL_prim_rsy_vf, qR_prim_rsy_vf, & - qL_prim_rsz_vf, qR_prim_rsz_vf - - type(vector_field), dimension(num_dims), intent(inout) :: qL_prim, qR_prim - - type(vector_field), intent(in) :: q_prim_qp - - type(vector_field), dimension(1:num_dims), & - intent(inout) :: dqL_prim_dx_n, dqR_prim_dx_n, & - dqL_prim_dy_n, dqR_prim_dy_n, & - dqL_prim_dz_n, dqR_prim_dz_n + !> Computes viscous terms + !! @param qL_prim_rsx_vf Left reconstructed primitive variables in x + !! @param qL_prim_rsy_vf Left reconstructed primitive variables in y + !! @param qL_prim_rsz_vf Left reconstructed primitive variables in z + !! @param dqL_prim_dx_n Left primitive x-derivative + !! @param dqL_prim_dy_n Left primitive y-derivative + !! @param dqL_prim_dz_n Left primitive z-derivative + !! @param qL_prim Left cell-boundary primitive variables + !! @param qR_prim_rsx_vf Right reconstructed primitive variables in x + !! @param qR_prim_rsy_vf Right reconstructed primitive variables in y + !! @param qR_prim_rsz_vf Right reconstructed primitive variables in z + !! @param dqR_prim_dx_n Right primitive x-derivative + !! @param dqR_prim_dy_n Right primitive y-derivative + !! @param dqR_prim_dz_n Right primitive z-derivative + !! @param qR_prim Right cell-boundary primitive variables + !! @param q_prim_qp Cell-averaged primitive variables + !! @param dq_prim_dx_qp Cell-averaged primitive x-derivative + !! @param dq_prim_dy_qp Cell-averaged primitive y-derivative + !! @param dq_prim_dz_qp Cell-averaged primitive z-derivative + !! @param ix Index bounds in the x-direction + !! @param iy Index bounds in the y-direction + !! @param iz Index bounds in the z-direction + subroutine s_get_viscous(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, & + & qL_prim, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, & + & dqR_prim_dz_n, qR_prim, q_prim_qp, dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, 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, qL_prim_rsy_vf, qR_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsz_vf + + type(vector_field), dimension(num_dims), intent(inout) :: qL_prim, qR_prim + type(vector_field), intent(in) :: q_prim_qp + type(vector_field), dimension(1:num_dims), intent(inout) :: dqL_prim_dx_n, dqR_prim_dx_n, dqL_prim_dy_n, dqR_prim_dy_n, & + & dqL_prim_dz_n, dqR_prim_dz_n type(vector_field), dimension(1), intent(inout) :: dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp - type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: i, j, k, l + type(int_bounds_info), intent(in) :: ix, iy, iz + integer :: i, j, k, l do i = 1, num_dims - iv%beg = mom_idx%beg; iv%end = mom_idx%end $:GPU_UPDATE(device='[iv]') - call s_reconstruct_cell_boundary_values_visc( & - q_prim_qp%vf(iv%beg:iv%end), & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & - i, qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & - ix, iy, iz) + call s_reconstruct_cell_boundary_values_visc(q_prim_qp%vf(iv%beg:iv%end), qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, i, & + & qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), ix, iy, iz) end do if (weno_Re_flux) then @@ -600,26 +531,19 @@ contains ! divergence theorem do i = 1, num_dims if (i == 1) then - call s_apply_scalar_divergence_theorem( & - qL_prim(i)%vf(iv%beg:iv%end), & - qR_prim(i)%vf(iv%beg:iv%end), & - dq_prim_dx_qp(1)%vf(iv%beg:iv%end), i, & - ix, iy, iz, iv, dx, m, buff_size) - elseif (i == 2) then - call s_apply_scalar_divergence_theorem( & - qL_prim(i)%vf(iv%beg:iv%end), & - qR_prim(i)%vf(iv%beg:iv%end), & - dq_prim_dy_qp(1)%vf(iv%beg:iv%end), i, & - ix, iy, iz, iv, dy, n, buff_size) + call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & + & dq_prim_dx_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dx, m, & + & buff_size) + else if (i == 2) then + call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & + & dq_prim_dy_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dy, n, & + & buff_size) else - call s_apply_scalar_divergence_theorem( & - qL_prim(i)%vf(iv%beg:iv%end), & - qR_prim(i)%vf(iv%beg:iv%end), & - dq_prim_dz_qp(1)%vf(iv%beg:iv%end), i, & - ix, iy, iz, iv, dz, p, buff_size) + call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & + & dq_prim_dz_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dz, p, & + & buff_size) end if end do - else ! Compute velocity gradient at cell centers using finite differences iv%beg = mom_idx%beg; iv%end = mom_idx%end @@ -627,7 +551,7 @@ contains is1_viscous = ix; is2_viscous = iy; is3_viscous = iz - $:GPU_UPDATE(device='[is1_viscous,is2_viscous,is3_viscous]') + $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous]') $:GPU_PARALLEL_LOOP(collapse=3) do l = is3_viscous%beg, is3_viscous%end @@ -635,10 +559,8 @@ contains do j = is1_viscous%beg + 1, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqL_prim_dx_n(1)%vf(i)%sf(j, k, l) = & - (q_prim_qp%vf(i)%sf(j, k, l) - & - q_prim_qp%vf(i)%sf(j - 1, k, l))/ & - (x_cc(j) - x_cc(j - 1)) + dqL_prim_dx_n(1)%vf(i)%sf(j, k, l) = (q_prim_qp%vf(i)%sf(j, k, l) - q_prim_qp%vf(i)%sf(j - 1, k, & + & l))/(x_cc(j) - x_cc(j - 1)) end do end do end do @@ -651,10 +573,8 @@ contains do j = is1_viscous%beg, is1_viscous%end - 1 $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqR_prim_dx_n(1)%vf(i)%sf(j, k, l) = & - (q_prim_qp%vf(i)%sf(j + 1, k, l) - & - q_prim_qp%vf(i)%sf(j, k, l))/ & - (x_cc(j + 1) - x_cc(j)) + dqR_prim_dx_n(1)%vf(i)%sf(j, k, l) = (q_prim_qp%vf(i)%sf(j + 1, k, l) - q_prim_qp%vf(i)%sf(j, k, & + & l))/(x_cc(j + 1) - x_cc(j)) end do end do end do @@ -662,7 +582,6 @@ contains $:END_GPU_PARALLEL_LOOP() if (n > 0) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 $:GPU_PARALLEL_LOOP(collapse=3) do l = is3_viscous%beg, is3_viscous%end @@ -670,10 +589,8 @@ contains do k = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqL_prim_dy_n(2)%vf(i)%sf(k, j, l) = & - (q_prim_qp%vf(i)%sf(k, j, l) - & - q_prim_qp%vf(i)%sf(k, j - 1, l))/ & - (y_cc(j) - y_cc(j - 1)) + dqL_prim_dy_n(2)%vf(i)%sf(k, j, l) = (q_prim_qp%vf(i)%sf(k, j, l) - q_prim_qp%vf(i)%sf(k, & + & j - 1, l))/(y_cc(j) - y_cc(j - 1)) end do end do end do @@ -686,10 +603,8 @@ contains do k = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqR_prim_dy_n(2)%vf(i)%sf(k, j, l) = & - (q_prim_qp%vf(i)%sf(k, j + 1, l) - & - q_prim_qp%vf(i)%sf(k, j, l))/ & - (y_cc(j + 1) - y_cc(j)) + dqR_prim_dy_n(2)%vf(i)%sf(k, j, l) = (q_prim_qp%vf(i)%sf(k, j + 1, l) - q_prim_qp%vf(i)%sf(k, & + & j, l))/(y_cc(j + 1) - y_cc(j)) end do end do end do @@ -702,14 +617,11 @@ contains do k = is1_viscous%beg + 1, is1_viscous%end - 1 $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = & - (dqL_prim_dx_n(1)%vf(i)%sf(k, j, l) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, j, l) + & - dqL_prim_dx_n(1)%vf(i)%sf(k, j - 1, l) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, j - 1, l)) - - dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp* & - dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) + dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dx_n(1)%vf(i)%sf(k, j, & + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j - 1, & + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j - 1, l)) + + dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) end do end do end do @@ -722,15 +634,11 @@ contains do k = is1_viscous%beg + 1, is1_viscous%end - 1 $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = & - (dqL_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + & - dqL_prim_dx_n(1)%vf(i)%sf(k, j, l) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, j, l)) - - dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp* & - dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) + dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dx_n(1)%vf(i)%sf(k, j + 1, & + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j, & + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l)) + dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) end do end do end do @@ -743,15 +651,11 @@ contains do j = is1_viscous%beg + 1, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = & - (dqL_prim_dy_n(2)%vf(i)%sf(j, k, l) + & - dqR_prim_dy_n(2)%vf(i)%sf(j, k, l) + & - dqL_prim_dy_n(2)%vf(i)%sf(j - 1, k, l) + & - dqR_prim_dy_n(2)%vf(i)%sf(j - 1, k, l)) - - dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp* & - dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) + dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dy_n(2)%vf(i)%sf(j, k, & + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j - 1, k, & + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j - 1, k, l)) + dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) end do end do end do @@ -764,21 +668,16 @@ contains do j = is1_viscous%beg, is1_viscous%end - 1 $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = & - (dqL_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + & - dqR_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + & - dqL_prim_dy_n(2)%vf(i)%sf(j, k, l) + & - dqR_prim_dy_n(2)%vf(i)%sf(j, k, l)) - - dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp* & - dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) + dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dy_n(2)%vf(i)%sf(j + 1, k, & + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j, k, & + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l)) + dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - #:endif if (p > 0) then @@ -789,11 +688,8 @@ contains do k = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - - dqL_prim_dz_n(3)%vf(i)%sf(k, l, j) = & - (q_prim_qp%vf(i)%sf(k, l, j) - & - q_prim_qp%vf(i)%sf(k, l, j - 1))/ & - (z_cc(j) - z_cc(j - 1)) + dqL_prim_dz_n(3)%vf(i)%sf(k, l, j) = (q_prim_qp%vf(i)%sf(k, l, j) - q_prim_qp%vf(i)%sf(k, & + & l, j - 1))/(z_cc(j) - z_cc(j - 1)) end do end do end do @@ -806,11 +702,8 @@ contains do k = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - - dqR_prim_dz_n(3)%vf(i)%sf(k, l, j) = & - (q_prim_qp%vf(i)%sf(k, l, j + 1) - & - q_prim_qp%vf(i)%sf(k, l, j))/ & - (z_cc(j + 1) - z_cc(j)) + dqR_prim_dz_n(3)%vf(i)%sf(k, l, j) = (q_prim_qp%vf(i)%sf(k, l, & + & j + 1) - q_prim_qp%vf(i)%sf(k, l, j))/(z_cc(j + 1) - z_cc(j)) end do end do end do @@ -823,16 +716,12 @@ contains do j = is1_viscous%beg + 1, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end + dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dz_n(3)%vf(i)%sf(j, k, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, & + & l) + dqL_prim_dz_n(3)%vf(i)%sf(j - 1, k, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j - 1, k, l)) - dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = & - (dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(j, k, l) + & - dqL_prim_dz_n(3)%vf(i)%sf(j - 1, k, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(j - 1, k, l)) - - dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp* & - dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) - + dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) end do end do end do @@ -845,16 +734,12 @@ contains do j = is1_viscous%beg, is1_viscous%end - 1 $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end + dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dz_n(3)%vf(i)%sf(j + 1, k, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j + 1, k, & + & l) + dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, & + & l)) - dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = & - (dqL_prim_dz_n(3)%vf(i)%sf(j + 1, k, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(j + 1, k, l) + & - dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(j, k, l)) - - dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp* & - dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) - + dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) end do end do end do @@ -867,16 +752,11 @@ contains do k = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end + dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dz_n(3)%vf(i)%sf(k, j, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l) + dqL_prim_dz_n(3)%vf(i)%sf(k, & + & j - 1, l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j - 1, l)) - dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = & - (dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(k, j, l) + & - dqL_prim_dz_n(3)%vf(i)%sf(k, j - 1, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(k, j - 1, l)) - - dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp* & - dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) - + dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) end do end do end do @@ -889,16 +769,12 @@ contains do k = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end + dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dz_n(3)%vf(i)%sf(k, j + 1, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j + 1, & + & l) + dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, & + & l)) - dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = & - (dqL_prim_dz_n(3)%vf(i)%sf(k, j + 1, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(k, j + 1, l) + & - dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + & - dqR_prim_dz_n(3)%vf(i)%sf(k, j, l)) - - dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp* & - dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) - + dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) end do end do end do @@ -911,16 +787,11 @@ contains do k = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end + dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dy_n(2)%vf(i)%sf(k, l, & + & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & + & j - 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j - 1)) - dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = & - (dqL_prim_dy_n(2)%vf(i)%sf(k, l, j) + & - dqR_prim_dy_n(2)%vf(i)%sf(k, l, j) + & - dqL_prim_dy_n(2)%vf(i)%sf(k, l, j - 1) + & - dqR_prim_dy_n(2)%vf(i)%sf(k, l, j - 1)) - - dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp* & - dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) - + dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) end do end do end do @@ -933,16 +804,12 @@ contains do k = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end + dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dy_n(2)%vf(i)%sf(k, l, & + & j + 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, & + & j + 1) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & + & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j)) - dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = & - (dqL_prim_dy_n(2)%vf(i)%sf(k, l, j + 1) + & - dqR_prim_dy_n(2)%vf(i)%sf(k, l, j + 1) + & - dqL_prim_dy_n(2)%vf(i)%sf(k, l, j) + & - dqR_prim_dy_n(2)%vf(i)%sf(k, l, j)) - - dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp* & - dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) - + dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) end do end do end do @@ -954,16 +821,11 @@ contains do k = is1_viscous%beg + 1, is1_viscous%end - 1 $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end + dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dx_n(1)%vf(i)%sf(k, l, & + & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & + & j - 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j - 1)) - dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = & - (dqL_prim_dx_n(1)%vf(i)%sf(k, l, j) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, l, j) + & - dqL_prim_dx_n(1)%vf(i)%sf(k, l, j - 1) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, l, j - 1)) - - dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp* & - dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) - + dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) end do end do end do @@ -975,15 +837,12 @@ contains do k = is1_viscous%beg + 1, is1_viscous%end - 1 $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = & - (dqL_prim_dx_n(1)%vf(i)%sf(k, l, j + 1) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, l, j + 1) + & - dqL_prim_dx_n(1)%vf(i)%sf(k, l, j) + & - dqR_prim_dx_n(1)%vf(i)%sf(k, l, j)) - - dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp* & - dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) + dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dx_n(1)%vf(i)%sf(k, l, & + & j + 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, & + & j + 1) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & + & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j)) + dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) end do end do end do @@ -991,53 +850,38 @@ contains $:END_GPU_PARALLEL_LOOP() do i = iv%beg, iv%end - call s_compute_fd_gradient(q_prim_qp%vf(i), & - dq_prim_dx_qp(1)%vf(i), & - dq_prim_dy_qp(1)%vf(i), & - dq_prim_dz_qp(1)%vf(i)) + call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dy_qp(1)%vf(i), & + & dq_prim_dz_qp(1)%vf(i)) end do #:endif - else do i = iv%beg, iv%end - call s_compute_fd_gradient(q_prim_qp%vf(i), & - dq_prim_dx_qp(1)%vf(i), & - dq_prim_dy_qp(1)%vf(i), & - dq_prim_dy_qp(1)%vf(i)) + call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dy_qp(1)%vf(i), & + & dq_prim_dy_qp(1)%vf(i)) end do - end if - else do i = iv%beg, iv%end - call s_compute_fd_gradient(q_prim_qp%vf(i), & - dq_prim_dx_qp(1)%vf(i), & - dq_prim_dx_qp(1)%vf(i), & - dq_prim_dx_qp(1)%vf(i)) + call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dx_qp(1)%vf(i), & + & dq_prim_dx_qp(1)%vf(i)) end do - end if - end if - end subroutine s_get_viscous - !> @brief Reconstructs left and right cell-boundary values of viscous primitive variables using WENO or MUSCL. - subroutine s_reconstruct_cell_boundary_values_visc(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & - norm_dir, vL_prim_vf, vR_prim_vf, ix, iy, iz) - - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z - integer, intent(in) :: norm_dir + subroutine s_reconstruct_cell_boundary_values_visc(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & + & vR_prim_vf, ix, iy, iz) + + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & + & vR_y, vR_z + integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: recon_dir !< Coordinate direction of the WENO reconstruction - - integer :: i, j, k, l + integer :: recon_dir !< Coordinate direction of the WENO reconstruction + integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] if (recon_type == ${TYPE}$ .or. dummy) then @@ -1047,37 +891,31 @@ contains is1_viscous = ix; is2_viscous = iy; is3_viscous = iz recon_dir = 1; is1_viscous%beg = is1_viscous%beg + ${SCHEME}$_polyn is1_viscous%end = is1_viscous%end - ${SCHEME}$_polyn - - elseif (norm_dir == 2) then + else if (norm_dir == 2) then is1_viscous = iy; is2_viscous = ix; is3_viscous = iz recon_dir = 2; is1_viscous%beg = is1_viscous%beg + ${SCHEME}$_polyn is1_viscous%end = is1_viscous%end - ${SCHEME}$_polyn - else is1_viscous = iz; is2_viscous = iy; is3_viscous = ix recon_dir = 3; is1_viscous%beg = is1_viscous%beg + ${SCHEME}$_polyn is1_viscous%end = is1_viscous%end - ${SCHEME}$_polyn - end if $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous, iv]') if (n > 0) then if (p > 0) then - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, iv%beg:iv%end), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, iv%beg:iv%end), & - recon_dir, & - is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & + & :, iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, :), & - recon_dir, & - is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & + & recon_dir, is1_viscous, is2_viscous, is3_viscous) end if else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, :), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, :), vR_z(:, :, :, :), & - recon_dir, & - is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & + & is3_viscous) end if end if #:endfor @@ -1097,7 +935,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - elseif (norm_dir == 3) then + else if (norm_dir == 3) then $:GPU_PARALLEL_LOOP(collapse=4) do i = iv%beg, iv%end do j = is1_viscous%beg, is1_viscous%end @@ -1110,7 +948,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - elseif (norm_dir == 1) then + else if (norm_dir == 1) then $:GPU_PARALLEL_LOOP(collapse=4) do i = iv%beg, iv%end do l = is3_viscous%beg, is3_viscous%end @@ -1126,22 +964,18 @@ contains end if end if end if - end subroutine s_reconstruct_cell_boundary_values_visc - !> @brief Reconstructs left and right cell-boundary values of viscous primitive variable derivatives using WENO or MUSCL. - subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, & - norm_dir, vL_prim_vf, vR_prim_vf, ix, iy, iz) - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z + subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & + & vR_prim_vf, ix, iy, iz) + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & + & vR_y, vR_z type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf - type(int_bounds_info), intent(in) :: ix, iy, iz - - integer, intent(IN) :: norm_dir - - integer :: recon_dir !< Coordinate direction of the WENO reconstruction - - integer :: i, j, k, l + type(int_bounds_info), intent(in) :: ix, iy, iz + integer, intent(in) :: norm_dir + integer :: recon_dir !< Coordinate direction of the WENO reconstruction + integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] if (recon_type == ${TYPE}$) then ! Reconstruction in s1-direction @@ -1150,38 +984,31 @@ contains is1_viscous = ix; is2_viscous = iy; is3_viscous = iz recon_dir = 1; is1_viscous%beg = is1_viscous%beg + ${SCHEME}$_polyn is1_viscous%end = is1_viscous%end - ${SCHEME}$_polyn - - elseif (norm_dir == 2) then + else if (norm_dir == 2) then is1_viscous = iy; is2_viscous = ix; is3_viscous = iz recon_dir = 2; is1_viscous%beg = is1_viscous%beg + ${SCHEME}$_polyn is1_viscous%end = is1_viscous%end - ${SCHEME}$_polyn - else is1_viscous = iz; is2_viscous = iy; is3_viscous = ix recon_dir = 3; is1_viscous%beg = is1_viscous%beg + ${SCHEME}$_polyn is1_viscous%end = is1_viscous%end - ${SCHEME}$_polyn - end if $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous, iv]') if (n > 0) then if (p > 0) then - - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, iv%beg:iv%end), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, iv%beg:iv%end), & - recon_dir, & - is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & + & :, iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, iv%beg:iv%end), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, iv%beg:iv%end), vR_z(:, :, :, :), & - recon_dir, & - is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & + & recon_dir, is1_viscous, is2_viscous, is3_viscous) end if else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), & - vL_x(:, :, :, iv%beg:iv%end), vL_y(:, :, :, :), vL_z(:, :, :, :), vR_x(:, :, :, iv%beg:iv%end), vR_y(:, :, :, :), vR_z(:, :, :, :), & - recon_dir, & - is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & + & is3_viscous) end if end if #:endfor @@ -1201,7 +1028,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - elseif (norm_dir == 3) then + else if (norm_dir == 3) then $:GPU_PARALLEL_LOOP(collapse=4) do i = iv%beg, iv%end do j = is1_viscous%beg, is1_viscous%end @@ -1214,7 +1041,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - elseif (norm_dir == 1) then + else if (norm_dir == 1) then $:GPU_PARALLEL_LOOP(collapse=4) do i = iv%beg, iv%end do l = is3_viscous%beg, is3_viscous%end @@ -1230,46 +1057,30 @@ contains end if end if end if - end subroutine s_reconstruct_cell_boundary_values_visc_deriv - - !> The purpose of this subroutine is to employ the inputted - !! left and right cell-boundary integral-averaged variables - !! to compute the relevant cell-average first-order spatial - !! derivatives in the x-, y- or z-direction by means of the - !! scalar divergence theorem. - !! @param vL_vf Left cell-boundary integral averages - !! @param vR_vf Right cell-boundary integral averages - !! @param dv_ds_vf Cell-average first-order spatial derivatives - !! @param norm_dir Splitting coordinate direction - !! @param ix Index bounds in the x-direction - !! @param iy Index bounds in the y-direction - !! @param iz Index bounds in the z-direction - !! @param iv_in Variable index bounds - !! @param dL Cell width array - !! @param dim Dimension size - !! @param buff_size_in Buffer layer size - subroutine s_apply_scalar_divergence_theorem(vL_vf, vR_vf, & - dv_ds_vf, & - norm_dir, & - ix, iy, iz, iv_in, & - dL, dim, buff_size_in) - + !> The purpose of this subroutine is to employ the inputted left and right cell-boundary integral-averaged variables to compute + !! the relevant cell-average first-order spatial derivatives in the x-, y- or z-direction by means of the scalar divergence + !! theorem. + !! @param vL_vf Left cell-boundary integral averages + !! @param vR_vf Right cell-boundary integral averages + !! @param dv_ds_vf Cell-average first-order spatial derivatives + !! @param norm_dir Splitting coordinate direction + !! @param ix Index bounds in the x-direction + !! @param iy Index bounds in the y-direction + !! @param iz Index bounds in the z-direction + !! @param iv_in Variable index bounds + !! @param dL Cell width array + !! @param dim Dimension size + !! @param buff_size_in Buffer layer size + subroutine s_apply_scalar_divergence_theorem(vL_vf, vR_vf, dv_ds_vf, norm_dir, ix, iy, iz, iv_in, dL, dim, buff_size_in) ! arrays of cell widths - type(scalar_field), & - dimension(iv%beg:iv%end), & - intent(in) :: vL_vf, vR_vf - - type(scalar_field), & - dimension(iv%beg:iv%end), & - intent(inout) :: dv_ds_vf - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz, iv_in - integer, intent(in) :: dim, buff_size_in + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: vL_vf, vR_vf + type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: dv_ds_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz, iv_in + integer, intent(in) :: dim, buff_size_in real(wp), dimension(-buff_size_in:dim + buff_size_in), intent(in) :: dL - - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators is1_viscous = ix is2_viscous = iy @@ -1280,7 +1091,6 @@ contains ! First-Order Spatial Derivatives in x-direction if (norm_dir == 1) then - ! A general application of the scalar divergence theorem that ! utilizes the left and right cell-boundary integral-averages, ! inside each cell, or an arithmetic mean of these two at the @@ -1293,12 +1103,8 @@ contains do j = is1_viscous%beg + 1, is1_viscous%end - 1 $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dv_ds_vf(i)%sf(j, k, l) = & - 1._wp/((1._wp + wa_flg)*dL(j)) & - *(wa_flg*vL_vf(i)%sf(j + 1, k, l) & - + vR_vf(i)%sf(j, k, l) & - - vL_vf(i)%sf(j, k, l) & - - wa_flg*vR_vf(i)%sf(j - 1, k, l)) + dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(j))*(wa_flg*vL_vf(i)%sf(j + 1, k, & + & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j - 1, k, l)) end do end do end do @@ -1308,8 +1114,7 @@ contains ! END: First-Order Spatial Derivatives in x-direction ! First-Order Spatial Derivatives in y-direction - elseif (norm_dir == 2) then - + else if (norm_dir == 2) then ! A general application of the scalar divergence theorem that ! utilizes the left and right cell-boundary integral-averages, ! inside each cell, or an arithmetic mean of these two at the @@ -1322,12 +1127,8 @@ contains do j = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dv_ds_vf(i)%sf(j, k, l) = & - 1._wp/((1._wp + wa_flg)*dL(k)) & - *(wa_flg*vL_vf(i)%sf(j, k + 1, l) & - + vR_vf(i)%sf(j, k, l) & - - vL_vf(i)%sf(j, k, l) & - - wa_flg*vR_vf(i)%sf(j, k - 1, l)) + dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(k))*(wa_flg*vL_vf(i)%sf(j, k + 1, & + & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k - 1, l)) end do end do end do @@ -1351,37 +1152,28 @@ contains do j = is1_viscous%beg, is1_viscous%end $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end - dv_ds_vf(i)%sf(j, k, l) = & - 1._wp/((1._wp + wa_flg)*dL(l)) & - *(wa_flg*vL_vf(i)%sf(j, k, l + 1) & - + vR_vf(i)%sf(j, k, l) & - - vL_vf(i)%sf(j, k, l) & - - wa_flg*vR_vf(i)%sf(j, k, l - 1)) + dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(l))*(wa_flg*vL_vf(i)%sf(j, k, & + & l + 1) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k, l - 1)) end do end do end do end do $:END_GPU_PARALLEL_LOOP() - end if ! END: First-Order Spatial Derivatives in z-direction - end subroutine s_apply_scalar_divergence_theorem - - !> Computes the scalar gradient fields via finite differences - !! @param var Variable to compute derivative of - !! @param grad_x First coordinate direction component of the derivative - !! @param grad_y Second coordinate direction component of the derivative - !! @param grad_z Third coordinate direction component of the derivative + !> Computes the scalar gradient fields via finite differences + !! @param var Variable to compute derivative of + !! @param grad_x First coordinate direction component of the derivative + !! @param grad_y Second coordinate direction component of the derivative + !! @param grad_z Third coordinate direction component of the derivative subroutine s_compute_fd_gradient(var, grad_x, grad_y, grad_z) - - type(scalar_field), intent(in) :: var + type(scalar_field), intent(in) :: var type(scalar_field), intent(inout) :: grad_x type(scalar_field), intent(inout) :: grad_y type(scalar_field), intent(inout) :: grad_z - type(int_bounds_info) :: ix, iy, iz - - integer :: j, k, l !< Generic loop iterators + type(int_bounds_info) :: ix, iy, iz + integer :: j, k, l !< Generic loop iterators ix%beg = 1 - buff_size; ix%end = m + buff_size - 1 if (n > 0) then @@ -1398,15 +1190,13 @@ contains is1_viscous = ix; is2_viscous = iy; is3_viscous = iz - $:GPU_UPDATE(device='[is1_viscous,is2_viscous,is3_viscous]') + $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous]') $:GPU_PARALLEL_LOOP(collapse=3) do l = is3_viscous%beg, is3_viscous%end do k = is2_viscous%beg, is2_viscous%end do j = is1_viscous%beg, is1_viscous%end - grad_x%sf(j, k, l) = & - (var%sf(j + 1, k, l) - var%sf(j - 1, k, l))/ & - (x_cc(j + 1) - x_cc(j - 1)) + grad_x%sf(j, k, l) = (var%sf(j + 1, k, l) - var%sf(j - 1, k, l))/(x_cc(j + 1) - x_cc(j - 1)) end do end do end do @@ -1417,9 +1207,7 @@ contains do l = is3_viscous%beg, is3_viscous%end do k = is2_viscous%beg, is2_viscous%end do j = is1_viscous%beg, is1_viscous%end - grad_y%sf(j, k, l) = & - (var%sf(j, k + 1, l) - var%sf(j, k - 1, l))/ & - (y_cc(k + 1) - y_cc(k - 1)) + grad_y%sf(j, k, l) = (var%sf(j, k + 1, l) - var%sf(j, k - 1, l))/(y_cc(k + 1) - y_cc(k - 1)) end do end do end do @@ -1431,9 +1219,7 @@ contains do l = is3_viscous%beg, is3_viscous%end do k = is2_viscous%beg, is2_viscous%end do j = is1_viscous%beg, is1_viscous%end - grad_z%sf(j, k, l) = & - (var%sf(j, k, l + 1) - var%sf(j, k, l - 1))/ & - (z_cc(l + 1) - z_cc(l - 1)) + grad_z%sf(j, k, l) = (var%sf(j, k, l + 1) - var%sf(j, k, l - 1))/(z_cc(l + 1) - z_cc(l - 1)) end do end do end do @@ -1443,12 +1229,10 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end - grad_x%sf(idwbuff(1)%beg, k, l) = & - (-3._wp*var%sf(idwbuff(1)%beg, k, l) + 4._wp*var%sf(idwbuff(1)%beg + 1, k, l) - var%sf(idwbuff(1)%beg + 2, k, l))/ & - (x_cc(idwbuff(1)%beg + 2) - x_cc(idwbuff(1)%beg)) - grad_x%sf(idwbuff(1)%end, k, l) = & - (+3._wp*var%sf(idwbuff(1)%end, k, l) - 4._wp*var%sf(idwbuff(1)%end - 1, k, l) + var%sf(idwbuff(1)%end - 2, k, l))/ & - (x_cc(idwbuff(1)%end) - x_cc(idwbuff(1)%end - 2)) + grad_x%sf(idwbuff(1)%beg, k, l) = (-3._wp*var%sf(idwbuff(1)%beg, k, l) + 4._wp*var%sf(idwbuff(1)%beg + 1, k, & + & l) - var%sf(idwbuff(1)%beg + 2, k, l))/(x_cc(idwbuff(1)%beg + 2) - x_cc(idwbuff(1)%beg)) + grad_x%sf(idwbuff(1)%end, k, l) = (+3._wp*var%sf(idwbuff(1)%end, k, l) - 4._wp*var%sf(idwbuff(1)%end - 1, k, & + & l) + var%sf(idwbuff(1)%end - 2, k, l))/(x_cc(idwbuff(1)%end) - x_cc(idwbuff(1)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1456,12 +1240,10 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do l = idwbuff(3)%beg, idwbuff(3)%end do j = idwbuff(1)%beg, idwbuff(1)%end - grad_y%sf(j, idwbuff(2)%beg, l) = & - (-3._wp*var%sf(j, idwbuff(2)%beg, l) + 4._wp*var%sf(j, idwbuff(2)%beg + 1, l) - var%sf(j, idwbuff(2)%beg + 2, l))/ & - (y_cc(idwbuff(2)%beg + 2) - y_cc(idwbuff(2)%beg)) - grad_y%sf(j, idwbuff(2)%end, l) = & - (+3._wp*var%sf(j, idwbuff(2)%end, l) - 4._wp*var%sf(j, idwbuff(2)%end - 1, l) + var%sf(j, idwbuff(2)%end - 2, l))/ & - (y_cc(idwbuff(2)%end) - y_cc(idwbuff(2)%end - 2)) + grad_y%sf(j, idwbuff(2)%beg, l) = (-3._wp*var%sf(j, idwbuff(2)%beg, l) + 4._wp*var%sf(j, idwbuff(2)%beg + 1, & + & l) - var%sf(j, idwbuff(2)%beg + 2, l))/(y_cc(idwbuff(2)%beg + 2) - y_cc(idwbuff(2)%beg)) + grad_y%sf(j, idwbuff(2)%end, l) = (+3._wp*var%sf(j, idwbuff(2)%end, l) - 4._wp*var%sf(j, idwbuff(2)%end - 1, & + & l) + var%sf(j, idwbuff(2)%end - 2, l))/(y_cc(idwbuff(2)%end) - y_cc(idwbuff(2)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1469,12 +1251,12 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end - grad_z%sf(j, k, idwbuff(3)%beg) = & - (-3._wp*var%sf(j, k, idwbuff(3)%beg) + 4._wp*var%sf(j, k, idwbuff(3)%beg + 1) - var%sf(j, k, idwbuff(3)%beg + 2))/ & - (z_cc(idwbuff(3)%beg + 2) - z_cc(is3_viscous%beg)) - grad_z%sf(j, k, idwbuff(3)%end) = & - (+3._wp*var%sf(j, k, idwbuff(3)%end) - 4._wp*var%sf(j, k, idwbuff(3)%end - 1) + var%sf(j, k, idwbuff(3)%end - 2))/ & - (z_cc(idwbuff(3)%end) - z_cc(idwbuff(3)%end - 2)) + grad_z%sf(j, k, idwbuff(3)%beg) = (-3._wp*var%sf(j, k, idwbuff(3)%beg) + 4._wp*var%sf(j, k, & + & idwbuff(3)%beg + 1) - var%sf(j, k, & + & idwbuff(3)%beg + 2))/(z_cc(idwbuff(3)%beg + 2) - z_cc(is3_viscous%beg)) + grad_z%sf(j, k, idwbuff(3)%end) = (+3._wp*var%sf(j, k, idwbuff(3)%end) - 4._wp*var%sf(j, k, & + & idwbuff(3)%end - 1) + var%sf(j, k, & + & idwbuff(3)%end - 2))/(z_cc(idwbuff(3)%end) - z_cc(idwbuff(3)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1485,8 +1267,7 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end - grad_x%sf(0, k, l) = (-3._wp*var%sf(0, k, l) + 4._wp*var%sf(1, k, l) - var%sf(2, k, l))/ & - (x_cc(2) - x_cc(0)) + grad_x%sf(0, k, l) = (-3._wp*var%sf(0, k, l) + 4._wp*var%sf(1, k, l) - var%sf(2, k, l))/(x_cc(2) - x_cc(0)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1495,8 +1276,8 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end - grad_x%sf(m, k, l) = (3._wp*var%sf(m, k, l) - 4._wp*var%sf(m - 1, k, l) + var%sf(m - 2, k, l))/ & - (x_cc(m) - x_cc(m - 2)) + grad_x%sf(m, k, l) = (3._wp*var%sf(m, k, l) - 4._wp*var%sf(m - 1, k, l) + var%sf(m - 2, k, & + & l))/(x_cc(m) - x_cc(m - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1506,8 +1287,7 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do l = idwbuff(3)%beg, idwbuff(3)%end do j = idwbuff(1)%beg, idwbuff(1)%end - grad_y%sf(j, 0, l) = (-3._wp*var%sf(j, 0, l) + 4._wp*var%sf(j, 1, l) - var%sf(j, 2, l))/ & - (y_cc(2) - y_cc(0)) + grad_y%sf(j, 0, l) = (-3._wp*var%sf(j, 0, l) + 4._wp*var%sf(j, 1, l) - var%sf(j, 2, l))/(y_cc(2) - y_cc(0)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1516,8 +1296,8 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do l = idwbuff(3)%beg, idwbuff(3)%end do j = idwbuff(1)%beg, idwbuff(1)%end - grad_y%sf(j, n, l) = (3._wp*var%sf(j, n, l) - 4._wp*var%sf(j, n - 1, l) + var%sf(j, n - 2, l))/ & - (y_cc(n) - y_cc(n - 2)) + grad_y%sf(j, n, l) = (3._wp*var%sf(j, n, l) - 4._wp*var%sf(j, n - 1, l) + var%sf(j, n - 2, & + & l))/(y_cc(n) - y_cc(n - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1527,9 +1307,8 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end - grad_z%sf(j, k, 0) = & - (-3._wp*var%sf(j, k, 0) + 4._wp*var%sf(j, k, 1) - var%sf(j, k, 2))/ & - (z_cc(2) - z_cc(0)) + grad_z%sf(j, k, 0) = (-3._wp*var%sf(j, k, 0) + 4._wp*var%sf(j, k, 1) - var%sf(j, k, & + & 2))/(z_cc(2) - z_cc(0)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1538,31 +1317,27 @@ contains $:GPU_PARALLEL_LOOP(collapse=2) do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end - grad_z%sf(j, k, p) = & - (3._wp*var%sf(j, k, p) - 4._wp*var%sf(j, k, p - 1) + var%sf(j, k, p - 2))/ & - (z_cc(p) - z_cc(p - 2)) + grad_z%sf(j, k, p) = (3._wp*var%sf(j, k, p) - 4._wp*var%sf(j, k, p - 1) + var%sf(j, k, & + & p - 2))/(z_cc(p) - z_cc(p - 2)) end do end do $:END_GPU_PARALLEL_LOOP() end if end if end if - end subroutine s_compute_fd_gradient - !> @brief Computes the viscous stress tensor at a single grid cell using finite-difference velocity gradients. subroutine s_compute_viscous_stress_tensor(viscous_stress_tensor, q_prim_vf, dynamic_viscosity, i, j, k) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), dimension(1:3, 1:3), intent(inout) :: viscous_stress_tensor + real(wp), dimension(1:3, 1:3), intent(inout) :: viscous_stress_tensor type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf - real(wp), intent(in) :: dynamic_viscosity - integer, intent(in) :: i, j, k - - real(wp), dimension(1:3, 1:3) :: velocity_gradient_tensor - real(wp), dimension(1:3) :: dx - real(wp) :: divergence - integer :: l, q ! iterators + real(wp), intent(in) :: dynamic_viscosity + integer, intent(in) :: i, j, k + real(wp), dimension(1:3, 1:3) :: velocity_gradient_tensor + real(wp), dimension(1:3) :: dx + real(wp) :: divergence + integer :: l, q ! iterators ! zero the viscous stress, collection of velocity derivatives, and spatial finite differences viscous_stress_tensor = 0._wp @@ -1578,10 +1353,13 @@ contains ! compute the velocity gradient tensor do l = 1, num_dims - velocity_gradient_tensor(l, 1) = (q_prim_vf(momxb + l - 1)%sf(i + 1, j, k) - q_prim_vf(momxb + l - 1)%sf(i - 1, j, k))/(2._wp*dx(1)) - velocity_gradient_tensor(l, 2) = (q_prim_vf(momxb + l - 1)%sf(i, j + 1, k) - q_prim_vf(momxb + l - 1)%sf(i, j - 1, k))/(2._wp*dx(2)) + velocity_gradient_tensor(l, 1) = (q_prim_vf(momxb + l - 1)%sf(i + 1, j, k) - q_prim_vf(momxb + l - 1)%sf(i - 1, j, & + & k))/(2._wp*dx(1)) + velocity_gradient_tensor(l, 2) = (q_prim_vf(momxb + l - 1)%sf(i, j + 1, k) - q_prim_vf(momxb + l - 1)%sf(i, j - 1, & + & k))/(2._wp*dx(2)) if (num_dims == 3) then - velocity_gradient_tensor(l, 3) = (q_prim_vf(momxb + l - 1)%sf(i, j, k + 1) - q_prim_vf(momxb + l - 1)%sf(i, j, k - 1))/(2._wp*dx(3)) + velocity_gradient_tensor(l, 3) = (q_prim_vf(momxb + l - 1)%sf(i, j, k + 1) - q_prim_vf(momxb + l - 1)%sf(i, j, & + & k - 1))/(2._wp*dx(3)) end if end do @@ -1609,14 +1387,9 @@ contains viscous_stress_tensor(l, 3) = 0._wp end do end if - end subroutine s_compute_viscous_stress_tensor - !> @brief Deallocates the viscous Reynolds number arrays. impure subroutine s_finalize_viscous_module() - @:DEALLOCATE(Res_viscous) - end subroutine s_finalize_viscous_module - end module m_viscous diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 0a7ca855d3..15bf9c966a 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -6,7 +6,6 @@ !> @brief WENO/WENO-Z/TENO reconstruction with optional monotonicity-preserving bounds and mapped weights module m_weno - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters @@ -21,61 +20,55 @@ module m_weno private; public :: s_initialize_weno_module, s_initialize_weno, s_finalize_weno_module, s_weno - !> @name The cell-average variables that will be WENO-reconstructed. Formerly, they - !! are stored in v_vf. However, they are transferred to v_rs_wsL and v_rs_wsR - !! as to be reshaped (RS) and/or characteristically decomposed. The reshaping - !! allows the WENO procedure to be independent of the coordinate direction of - !! the reconstruction. Lastly, notice that the left (L) and right (R) results - !! of the characteristic decomposition are stored in custom-constructed WENO- - !! stencils (WS) that are annexed to each position of a given scalar field. + !> @name The cell-average variables that will be WENO-reconstructed. Formerly, they are stored in v_vf. However, they are + !! transferred to v_rs_wsL and v_rs_wsR as to be reshaped (RS) and/or characteristically decomposed. The reshaping allows the + !! WENO procedure to be independent of the coordinate direction of the reconstruction. Lastly, notice that the left (L) and + !! right (R) results of the characteristic decomposition are stored in custom-constructed WENO- stencils (WS) that are annexed + !! to each position of a given scalar field. !> @{ - real(wp), allocatable, dimension(:, :, :, :) :: v_rs_ws_x, v_rs_ws_y, v_rs_ws_z + real(wp), allocatable, dimension(:,:,:,:) :: v_rs_ws_x, v_rs_ws_y, v_rs_ws_z !> @} - $:GPU_DECLARE(create='[v_rs_ws_x,v_rs_ws_y,v_rs_ws_z]') + $:GPU_DECLARE(create='[v_rs_ws_x, v_rs_ws_y, v_rs_ws_z]') ! WENO Coefficients - !> @name Polynomial coefficients at the left and right cell-boundaries (CB) and at - !! the left and right quadrature points (QP), in the x-, y- and z-directions. - !! Note that the first dimension of the array identifies the polynomial, the - !! second dimension identifies the position of its coefficients and the last - !! dimension denotes the cell-location in the relevant coordinate direction. + !> @name Polynomial coefficients at the left and right cell-boundaries (CB) and at the left and right quadrature points (QP), in + !! the x-, y- and z-directions. Note that the first dimension of the array identifies the polynomial, the second dimension + !! identifies the position of its coefficients and the last dimension denotes the cell-location in the relevant coordinate + !! direction. !> @{ - real(wp), target, allocatable, dimension(:, :, :) :: poly_coef_cbL_x - real(wp), target, allocatable, dimension(:, :, :) :: poly_coef_cbL_y - real(wp), target, allocatable, dimension(:, :, :) :: poly_coef_cbL_z - real(wp), target, allocatable, dimension(:, :, :) :: poly_coef_cbR_x - real(wp), target, allocatable, dimension(:, :, :) :: poly_coef_cbR_y - real(wp), target, allocatable, dimension(:, :, :) :: poly_coef_cbR_z + real(wp), target, allocatable, dimension(:,:,:) :: poly_coef_cbL_x + real(wp), target, allocatable, dimension(:,:,:) :: poly_coef_cbL_y + real(wp), target, allocatable, dimension(:,:,:) :: poly_coef_cbL_z + real(wp), target, allocatable, dimension(:,:,:) :: poly_coef_cbR_x + real(wp), target, allocatable, dimension(:,:,:) :: poly_coef_cbR_y + real(wp), target, allocatable, dimension(:,:,:) :: poly_coef_cbR_z !> @} - $:GPU_DECLARE(create='[poly_coef_cbL_x,poly_coef_cbL_y,poly_coef_cbL_z]') - $:GPU_DECLARE(create='[poly_coef_cbR_x,poly_coef_cbR_y,poly_coef_cbR_z]') + $:GPU_DECLARE(create='[poly_coef_cbL_x, poly_coef_cbL_y, poly_coef_cbL_z]') + $:GPU_DECLARE(create='[poly_coef_cbR_x, poly_coef_cbR_y, poly_coef_cbR_z]') - !> @name The ideal weights at the left and the right cell-boundaries and at the - !! left and the right quadrature points, in x-, y- and z-directions. Note - !! that the first dimension of the array identifies the weight, while the - !! last denotes the cell-location in the relevant coordinate direction. + !> @name The ideal weights at the left and the right cell-boundaries and at the left and the right quadrature points, in x-, y- + !! and z-directions. Note that the first dimension of the array identifies the weight, while the last denotes the cell-location + !! in the relevant coordinate direction. !> @{ - real(wp), target, allocatable, dimension(:, :) :: d_cbL_x - real(wp), target, allocatable, dimension(:, :) :: d_cbL_y - real(wp), target, allocatable, dimension(:, :) :: d_cbL_z - - real(wp), target, allocatable, dimension(:, :) :: d_cbR_x - real(wp), target, allocatable, dimension(:, :) :: d_cbR_y - real(wp), target, allocatable, dimension(:, :) :: d_cbR_z + real(wp), target, allocatable, dimension(:,:) :: d_cbL_x + real(wp), target, allocatable, dimension(:,:) :: d_cbL_y + real(wp), target, allocatable, dimension(:,:) :: d_cbL_z + real(wp), target, allocatable, dimension(:,:) :: d_cbR_x + real(wp), target, allocatable, dimension(:,:) :: d_cbR_y + real(wp), target, allocatable, dimension(:,:) :: d_cbR_z !> @} - $:GPU_DECLARE(create='[d_cbL_x,d_cbL_y,d_cbL_z,d_cbR_x,d_cbR_y,d_cbR_z]') + $:GPU_DECLARE(create='[d_cbL_x, d_cbL_y, d_cbL_z, d_cbR_x, d_cbR_y, d_cbR_z]') - !> @name Smoothness indicator coefficients in the x-, y-, and z-directions. Note - !! that the first array dimension identifies the smoothness indicator, the - !! second identifies the position of its coefficients and the last denotes - !! the cell-location in the relevant coordinate direction. + !> @name Smoothness indicator coefficients in the x-, y-, and z-directions. Note that the first array dimension identifies the + !! smoothness indicator, the second identifies the position of its coefficients and the last denotes the cell-location in the + !! relevant coordinate direction. !> @{ - real(wp), target, allocatable, dimension(:, :, :) :: beta_coef_x - real(wp), target, allocatable, dimension(:, :, :) :: beta_coef_y - real(wp), target, allocatable, dimension(:, :, :) :: beta_coef_z + real(wp), target, allocatable, dimension(:,:,:) :: beta_coef_x + real(wp), target, allocatable, dimension(:,:,:) :: beta_coef_y + real(wp), target, allocatable, dimension(:,:,:) :: beta_coef_z !> @} - $:GPU_DECLARE(create='[beta_coef_x,beta_coef_y,beta_coef_z]') + $:GPU_DECLARE(create='[beta_coef_x, beta_coef_y, beta_coef_z]') ! END: WENO Coefficients @@ -86,18 +79,15 @@ module m_weno !> @{ type(int_bounds_info) :: is1_weno, is2_weno, is3_weno #ifndef __NVCOMPILER_GPU_UNIFIED_MEM - $:GPU_DECLARE(create='[is1_weno,is2_weno,is3_weno]') + $:GPU_DECLARE(create='[is1_weno, is2_weno, is3_weno]') #endif ! !> @} - contains - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are necessary to setup the module. impure subroutine s_initialize_weno_module - if (weno_order == 1) return ! Allocating/Computing WENO Coefficients in x-direction @@ -105,7 +95,7 @@ contains if (n == 0) then is2_weno%beg = 0 else - is2_weno%beg = -buff_size; + is2_weno%beg = -buff_size; end if is2_weno%end = n - is2_weno%beg @@ -118,23 +108,19 @@ contains is3_weno%end = p - is3_weno%beg - @:ALLOCATE(poly_coef_cbL_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) - @:ALLOCATE(poly_coef_cbR_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + @:ALLOCATE(poly_coef_cbL_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn - 1)) + @:ALLOCATE(poly_coef_cbR_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn - 1)) @:ALLOCATE(d_cbL_x(0:weno_num_stencils, is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn)) @:ALLOCATE(d_cbR_x(0:weno_num_stencils, is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn)) - @:ALLOCATE(beta_coef_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + @:ALLOCATE(beta_coef_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn*(weno_polyn + 1)/2 - 1)) ! Number of cross terms for dvd = (k-1)(k-1+1)/2, where weno_polyn = k-1 ! Note: k-1 not k because we are using value differences (dvd) not the values themselves call s_compute_weno_coefficients(1, is1_weno) - @:ALLOCATE(v_rs_ws_x(is1_weno%beg:is1_weno%end, & - is2_weno%beg:is2_weno%end, is3_weno%beg:is3_weno%end, 1:sys_size)) + @:ALLOCATE(v_rs_ws_x(is1_weno%beg:is1_weno%end, is2_weno%beg:is2_weno%end, is3_weno%beg:is3_weno%end, 1:sys_size)) ! Allocating/Computing WENO Coefficients in y-direction if (n == 0) return @@ -150,21 +136,17 @@ contains is3_weno%end = p - is3_weno%beg - @:ALLOCATE(poly_coef_cbL_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) - @:ALLOCATE(poly_coef_cbR_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + @:ALLOCATE(poly_coef_cbL_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn - 1)) + @:ALLOCATE(poly_coef_cbR_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn - 1)) @:ALLOCATE(d_cbL_y(0:weno_num_stencils, is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn)) @:ALLOCATE(d_cbR_y(0:weno_num_stencils, is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn)) - @:ALLOCATE(beta_coef_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + @:ALLOCATE(beta_coef_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn*(weno_polyn + 1)/2 - 1)) call s_compute_weno_coefficients(2, is2_weno) - @:ALLOCATE(v_rs_ws_y(is2_weno%beg:is2_weno%end, & - is1_weno%beg:is1_weno%end, is3_weno%beg:is3_weno%end, 1:sys_size)) + @:ALLOCATE(v_rs_ws_y(is2_weno%beg:is2_weno%end, is1_weno%beg:is1_weno%end, is3_weno%beg:is3_weno%end, 1:sys_size)) ! Allocating/Computing WENO Coefficients in z-direction if (p == 0) return @@ -173,53 +155,40 @@ contains is1_weno%beg = -buff_size; is1_weno%end = m - is1_weno%beg is3_weno%beg = -buff_size; is3_weno%end = p - is3_weno%beg - @:ALLOCATE(poly_coef_cbL_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) - @:ALLOCATE(poly_coef_cbR_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn - 1)) + @:ALLOCATE(poly_coef_cbL_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn - 1)) + @:ALLOCATE(poly_coef_cbR_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn - 1)) @:ALLOCATE(d_cbL_z(0:weno_num_stencils, is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn)) @:ALLOCATE(d_cbR_z(0:weno_num_stencils, is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn)) - @:ALLOCATE(beta_coef_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, & - 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + @:ALLOCATE(beta_coef_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn*(weno_polyn + 1)/2 - 1)) call s_compute_weno_coefficients(3, is3_weno) - @:ALLOCATE(v_rs_ws_z(is3_weno%beg:is3_weno%end, & - is2_weno%beg:is2_weno%end, is1_weno%beg:is1_weno%end, 1:sys_size)) - + @:ALLOCATE(v_rs_ws_z(is3_weno%beg:is3_weno%end, is2_weno%beg:is2_weno%end, is1_weno%beg:is1_weno%end, 1:sys_size)) end subroutine s_initialize_weno_module - - !> The purpose of this subroutine is to compute the grid - !! dependent coefficients of the WENO polynomials, ideal - !! weights and smoothness indicators, provided the order, - !! the coordinate direction and the location of the WENO - !! reconstruction. + !> The purpose of this subroutine is to compute the grid dependent coefficients of the WENO polynomials, ideal weights and + !! smoothness indicators, provided the order, the coordinate direction and the location of the WENO reconstruction. !! @param weno_dir Coordinate direction of the WENO reconstruction !! @param is Index bounds in the s-direction subroutine s_compute_weno_coefficients(weno_dir, is) - - integer, intent(in) :: weno_dir + integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is - integer :: s - - real(wp), pointer, dimension(:) :: s_cb => null() !< + integer :: s + real(wp), pointer, dimension(:) :: s_cb => null() !< !! Cell-boundary locations in the s-direction type(int_bounds_info) :: bc_s !< Boundary conditions (BC) in the s-direction - - integer :: i !< Generic loop iterator - - real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil - real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil + integer :: i !< Generic loop iterator + real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil + real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil ! Determining the number of cells, the cell-boundary locations and ! the boundary conditions in the coordinate direction selected for ! the WENO reconstruction if (weno_dir == 1) then s = m; s_cb => x_cb; bc_s = bc_x - elseif (weno_dir == 2) then + else if (weno_dir == 2) then s = n; s_cb => y_cb; bc_s = bc_y else s = p; s_cb => z_cb; bc_s = bc_z @@ -230,28 +199,20 @@ contains if (weno_dir == ${WENO_DIR}$) then if (weno_order == 3) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn - - poly_coef_cbR_${XYZ}$ (i + 1, 0, 0) = (s_cb(i) - s_cb(i + 1))/ & - (s_cb(i) - s_cb(i + 2)) - poly_coef_cbR_${XYZ}$ (i + 1, 1, 0) = (s_cb(i) - s_cb(i + 1))/ & - (s_cb(i - 1) - s_cb(i + 1)) + poly_coef_cbR_${XYZ}$ (i + 1, 0, 0) = (s_cb(i) - s_cb(i + 1))/(s_cb(i) - s_cb(i + 2)) + poly_coef_cbR_${XYZ}$ (i + 1, 1, 0) = (s_cb(i) - s_cb(i + 1))/(s_cb(i - 1) - s_cb(i + 1)) poly_coef_cbL_${XYZ}$ (i + 1, 0, 0) = -poly_coef_cbR_${XYZ}$ (i + 1, 0, 0) poly_coef_cbL_${XYZ}$ (i + 1, 1, 0) = -poly_coef_cbR_${XYZ}$ (i + 1, 1, 0) - d_cbR_${XYZ}$ (0, i + 1) = (s_cb(i - 1) - s_cb(i + 1))/ & - (s_cb(i - 1) - s_cb(i + 2)) - d_cbL_${XYZ}$ (0, i + 1) = (s_cb(i - 1) - s_cb(i))/ & - (s_cb(i - 1) - s_cb(i + 2)) + d_cbR_${XYZ}$ (0, i + 1) = (s_cb(i - 1) - s_cb(i + 1))/(s_cb(i - 1) - s_cb(i + 2)) + d_cbL_${XYZ}$ (0, i + 1) = (s_cb(i - 1) - s_cb(i))/(s_cb(i - 1) - s_cb(i + 2)) d_cbR_${XYZ}$ (1, i + 1) = 1._wp - d_cbR_${XYZ}$ (0, i + 1) d_cbL_${XYZ}$ (1, i + 1) = 1._wp - d_cbL_${XYZ}$ (0, i + 1) - beta_coef_${XYZ}$ (i + 1, 0, 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp/ & - (s_cb(i) - s_cb(i + 2))**2._wp - beta_coef_${XYZ}$ (i + 1, 1, 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp/ & - (s_cb(i - 1) - s_cb(i + 1))**2._wp - + beta_coef_${XYZ}$ (i + 1, 0, 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp/(s_cb(i) - s_cb(i + 2))**2._wp + beta_coef_${XYZ}$ (i + 1, 1, 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp/(s_cb(i - 1) - s_cb(i + 1))**2._wp end do ! Modifying the ideal weights coefficients in the neighborhood @@ -272,132 +233,111 @@ contains ! END: Computing WENO3 Coefficients ! Computing WENO5 Coefficients - elseif (weno_order == 5) then - + else if (weno_order == 5) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn - - poly_coef_cbR_${XYZ}$ (i + 1, 0, 0) = & - ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/ & - ((s_cb(i) - s_cb(i + 3))*(s_cb(i + 3) - s_cb(i + 1))) - poly_coef_cbR_${XYZ}$ (i + 1, 1, 0) = & - ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i)))/ & - ((s_cb(i - 1) - s_cb(i + 2))*(s_cb(i + 2) - s_cb(i))) - poly_coef_cbR_${XYZ}$ (i + 1, 1, 1) = & - ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/ & - ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i - 1) - s_cb(i + 2))) - poly_coef_cbR_${XYZ}$ (i + 1, 2, 1) = & - ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/ & - ((s_cb(i - 2) - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))) - poly_coef_cbL_${XYZ}$ (i + 1, 0, 0) = & - ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/ & - ((s_cb(i) - s_cb(i + 3))*(s_cb(i + 3) - s_cb(i + 1))) - poly_coef_cbL_${XYZ}$ (i + 1, 1, 0) = & - ((s_cb(i) - s_cb(i - 1))*(s_cb(i) - s_cb(i + 1)))/ & - ((s_cb(i - 1) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 2))) - poly_coef_cbL_${XYZ}$ (i + 1, 1, 1) = & - ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/ & - ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i - 1) - s_cb(i + 2))) - poly_coef_cbL_${XYZ}$ (i + 1, 2, 1) = & - ((s_cb(i - 1) - s_cb(i))*(s_cb(i) - s_cb(i + 1)))/ & - ((s_cb(i - 2) - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))) - - poly_coef_cbR_${XYZ}$ (i + 1, 0, 1) = & - ((s_cb(i) - s_cb(i + 2)) + (s_cb(i + 1) - s_cb(i + 3)))/ & - ((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3)))* & - ((s_cb(i) - s_cb(i + 1))) - poly_coef_cbR_${XYZ}$ (i + 1, 2, 0) = & - ((s_cb(i - 2) - s_cb(i + 1)) + (s_cb(i - 1) - s_cb(i + 1)))/ & - ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 2)))* & - ((s_cb(i + 1) - s_cb(i))) - poly_coef_cbL_${XYZ}$ (i + 1, 0, 1) = & - ((s_cb(i) - s_cb(i + 2)) + (s_cb(i) - s_cb(i + 3)))/ & - ((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3)))* & - ((s_cb(i + 1) - s_cb(i))) - poly_coef_cbL_${XYZ}$ (i + 1, 2, 0) = & - ((s_cb(i - 2) - s_cb(i)) + (s_cb(i - 1) - s_cb(i + 1)))/ & - ((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))* & - ((s_cb(i) - s_cb(i + 1))) - - d_cbR_${XYZ}$ (0, i + 1) = & - ((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/ & - ((s_cb(i - 2) - s_cb(i + 3))*(s_cb(i + 3) - s_cb(i - 1))) - d_cbR_${XYZ}$ (2, i + 1) = & - ((s_cb(i + 1) - s_cb(i + 2))*(s_cb(i + 1) - s_cb(i + 3)))/ & - ((s_cb(i - 2) - s_cb(i + 2))*(s_cb(i - 2) - s_cb(i + 3))) - d_cbL_${XYZ}$ (0, i + 1) = & - ((s_cb(i - 2) - s_cb(i))*(s_cb(i) - s_cb(i - 1)))/ & - ((s_cb(i - 2) - s_cb(i + 3))*(s_cb(i + 3) - s_cb(i - 1))) - d_cbL_${XYZ}$ (2, i + 1) = & - ((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3)))/ & - ((s_cb(i - 2) - s_cb(i + 2))*(s_cb(i - 2) - s_cb(i + 3))) + poly_coef_cbR_${XYZ}$ (i + 1, 0, & + & 0) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i) - s_cb(i & + & + 3))*(s_cb(i + 3) - s_cb(i + 1))) + poly_coef_cbR_${XYZ}$ (i + 1, 1, & + & 0) = ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) & + & - s_cb(i + 2))*(s_cb(i + 2) - s_cb(i))) + poly_coef_cbR_${XYZ}$ (i + 1, 1, & + & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i - 1) & + & - s_cb(i + 1))*(s_cb(i - 1) - s_cb(i + 2))) + poly_coef_cbR_${XYZ}$ (i + 1, 2, & + & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) & + & - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))) + poly_coef_cbL_${XYZ}$ (i + 1, 0, & + & 0) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i) - s_cb(i + 3)) & + & *(s_cb(i + 3) - s_cb(i + 1))) + poly_coef_cbL_${XYZ}$ (i + 1, 1, & + & 0) = ((s_cb(i) - s_cb(i - 1))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 1) - s_cb(i & + & + 2))*(s_cb(i) - s_cb(i + 2))) + poly_coef_cbL_${XYZ}$ (i + 1, 1, & + & 1) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i - 1) - s_cb(i & + & + 1))*(s_cb(i - 1) - s_cb(i + 2))) + poly_coef_cbL_${XYZ}$ (i + 1, 2, & + & 1) = ((s_cb(i - 1) - s_cb(i))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 2) - s_cb(i)) & + & *(s_cb(i - 2) - s_cb(i + 1))) + + poly_coef_cbR_${XYZ}$ (i + 1, 0, & + & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i) - s_cb(i & + & + 2))*(s_cb(i) - s_cb(i + 3)))*((s_cb(i) - s_cb(i + 1))) + poly_coef_cbR_${XYZ}$ (i + 1, 2, & + & 0) = ((s_cb(i - 2) - s_cb(i + 1)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 1) & + & - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 2)))*((s_cb(i + 1) - s_cb(i))) + poly_coef_cbL_${XYZ}$ (i + 1, 0, & + & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i) - s_cb(i + 3)))/((s_cb(i) - s_cb(i + 2)) & + & *(s_cb(i) - s_cb(i + 3)))*((s_cb(i + 1) - s_cb(i))) + poly_coef_cbL_${XYZ}$ (i + 1, 2, & + & 0) = ((s_cb(i - 2) - s_cb(i)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 2) & + & - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))*((s_cb(i) - s_cb(i + 1))) + + d_cbR_${XYZ}$ (0, & + & i + 1) = ((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) & + & - s_cb(i + 3))*(s_cb(i + 3) - s_cb(i - 1))) + d_cbR_${XYZ}$ (2, & + & i + 1) = ((s_cb(i + 1) - s_cb(i + 2))*(s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i - 2) & + & - s_cb(i + 2))*(s_cb(i - 2) - s_cb(i + 3))) + d_cbL_${XYZ}$ (0, & + & i + 1) = ((s_cb(i - 2) - s_cb(i))*(s_cb(i) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i + 3)) & + & *(s_cb(i + 3) - s_cb(i - 1))) + d_cbL_${XYZ}$ (2, & + & i + 1) = ((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3)))/((s_cb(i - 2) - s_cb(i + 2)) & + & *(s_cb(i - 2) - s_cb(i + 3))) d_cbR_${XYZ}$ (1, i + 1) = 1._wp - d_cbR_${XYZ}$ (0, i + 1) - d_cbR_${XYZ}$ (2, i + 1) d_cbL_${XYZ}$ (1, i + 1) = 1._wp - d_cbL_${XYZ}$ (0, i + 1) - d_cbL_${XYZ}$ (2, i + 1) - beta_coef_${XYZ}$ (i + 1, 0, 0) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - & - s_cb(i))**2._wp + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - & - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2._wp)/((s_cb(i) - & - s_cb(i + 3))**2._wp*(s_cb(i + 1) - s_cb(i + 3))**2._wp) - - beta_coef_${XYZ}$ (i + 1, 0, 1) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - & - s_cb(i))**2._wp - (s_cb(i + 1) - s_cb(i))*(s_cb(i + 3) - & - s_cb(i + 1)) + 2._wp*(s_cb(i + 2) - s_cb(i))*((s_cb(i + 2) - & - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))))/((s_cb(i) - & - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 3) - & - s_cb(i + 1))) - - beta_coef_${XYZ}$ (i + 1, 0, 2) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - & - s_cb(i))**2._wp + (s_cb(i + 1) - s_cb(i))*((s_cb(i + 2) - & - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))) + ((s_cb(i + 2) - & - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1)))**2._wp)/((s_cb(i) - & - s_cb(i + 2))**2._wp*(s_cb(i) - s_cb(i + 3))**2._wp) - - beta_coef_${XYZ}$ (i + 1, 1, 0) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - & - s_cb(i))**2._wp + (s_cb(i) - s_cb(i - 1))**2._wp + (s_cb(i) - & - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) - & - s_cb(i + 2))**2._wp*(s_cb(i) - s_cb(i + 2))**2._wp) - - beta_coef_${XYZ}$ (i + 1, 1, 1) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*((s_cb(i) - & - s_cb(i + 1))*((s_cb(i) - s_cb(i - 1)) + 20._wp*(s_cb(i + 1) - & - s_cb(i))) + (2._wp*(s_cb(i) - s_cb(i - 1)) + (s_cb(i + 1) - & - s_cb(i)))*(s_cb(i + 2) - s_cb(i)))/((s_cb(i + 1) - & - s_cb(i - 1))*(s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i + 2) - & - s_cb(i))) - - beta_coef_${XYZ}$ (i + 1, 1, 2) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - & - s_cb(i))**2._wp + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - & - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2._wp)/ & - ((s_cb(i - 1) - s_cb(i + 1))**2._wp*(s_cb(i - 1) - & - s_cb(i + 2))**2._wp) - - beta_coef_${XYZ}$ (i + 1, 2, 0) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(12._wp*(s_cb(i + 1) - & - s_cb(i))**2._wp + ((s_cb(i) - s_cb(i - 2)) + (s_cb(i) - & - s_cb(i - 1)))**2._wp + 3._wp*((s_cb(i) - s_cb(i - 2)) + & - (s_cb(i) - s_cb(i - 1)))*(s_cb(i + 1) - s_cb(i)))/ & - ((s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i - 1) - & - s_cb(i + 1))**2._wp) - - beta_coef_${XYZ}$ (i + 1, 2, 1) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - & - s_cb(i))**2._wp + ((s_cb(i) - s_cb(i - 2))*(s_cb(i) - & - s_cb(i + 1))) + 2._wp*(s_cb(i + 1) - s_cb(i - 1))*((s_cb(i) - & - s_cb(i - 2)) + (s_cb(i + 1) - s_cb(i - 1))))/((s_cb(i - 2) - & - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i + 1) - & - s_cb(i - 1))) - - beta_coef_${XYZ}$ (i + 1, 2, 2) = & - 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - & - s_cb(i))**2._wp + (s_cb(i) - s_cb(i - 1))**2._wp + (s_cb(i) - & - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) - & - s_cb(i))**2._wp*(s_cb(i - 2) - s_cb(i + 1))**2._wp) - + beta_coef_${XYZ}$ (i + 1, 0, & + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1)) & + & **2._wp)/((s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 1) - s_cb(i + 3))**2._wp) + + beta_coef_${XYZ}$ (i + 1, 0, & + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & - (s_cb(i + 1) - s_cb(i))*(s_cb(i + 3) - s_cb(i + 1)) + 2._wp*(s_cb(i + 2) - s_cb(i)) & + & *((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))))/((s_cb(i) - s_cb(i + 2)) & + & *(s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 3) - s_cb(i + 1))) + + beta_coef_${XYZ}$ (i + 1, 0, & + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i + 1) - s_cb(i))*((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))) & + & + ((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1)))**2._wp)/((s_cb(i) - s_cb(i & + & + 2))**2._wp*(s_cb(i) - s_cb(i + 3))**2._wp) + + beta_coef_${XYZ}$ (i + 1, 1, & + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i) - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i))) & + & /((s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i) - s_cb(i + 2))**2._wp) + + beta_coef_${XYZ}$ (i + 1, 1, & + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*((s_cb(i) - s_cb(i + 1))*((s_cb(i) & + & - s_cb(i - 1)) + 20._wp*(s_cb(i + 1) - s_cb(i))) + (2._wp*(s_cb(i) - s_cb(i - 1)) & + & + (s_cb(i + 1) - s_cb(i)))*(s_cb(i + 2) - s_cb(i)))/((s_cb(i + 1) - s_cb(i - 1)) & + & *(s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i + 2) - s_cb(i))) + + beta_coef_${XYZ}$ (i + 1, 1, & + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1)) & + & **2._wp)/((s_cb(i - 1) - s_cb(i + 1))**2._wp*(s_cb(i - 1) - s_cb(i + 2))**2._wp) + + beta_coef_${XYZ}$ (i + 1, 2, & + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(12._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + ((s_cb(i) - s_cb(i - 2)) + (s_cb(i) - s_cb(i - 1)))**2._wp + 3._wp*((s_cb(i) & + & - s_cb(i - 2)) + (s_cb(i) - s_cb(i - 1)))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) & + & - s_cb(i + 1))**2._wp*(s_cb(i - 1) - s_cb(i + 1))**2._wp) + + beta_coef_${XYZ}$ (i + 1, 2, & + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + ((s_cb(i) - s_cb(i - 2))*(s_cb(i) - s_cb(i + 1))) + 2._wp*(s_cb(i + 1) - s_cb(i & + & - 1))*((s_cb(i) - s_cb(i - 2)) + (s_cb(i + 1) - s_cb(i - 1))))/((s_cb(i - 2) & + & - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i + 1) - s_cb(i - 1))) + + beta_coef_${XYZ}$ (i + 1, 2, & + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i) - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i))) & + & /((s_cb(i - 2) - s_cb(i))**2._wp*(s_cb(i - 2) - s_cb(i + 1))**2._wp) end do ! Modifying the ideal weights coefficients in the neighborhood @@ -413,258 +353,552 @@ contains end if if (bc_s%end == BC_RIEMANN_EXTRAP) then - d_cbR_${XYZ}$ (0, s - 1) = 0._wp; d_cbR_${XYZ}$ (:, s - 1) = d_cbR_${XYZ}$ (:, s - 1)/sum(d_cbR_${XYZ}$ (:, s - 1)) - d_cbL_${XYZ}$ (0, s - 1) = 0._wp; d_cbL_${XYZ}$ (:, s - 1) = d_cbL_${XYZ}$ (:, s - 1)/sum(d_cbL_${XYZ}$ (:, s - 1)) + d_cbR_${XYZ}$ (0, s - 1) = 0._wp; d_cbR_${XYZ}$ (:, s - 1) = d_cbR_${XYZ}$ (:, & + & s - 1)/sum(d_cbR_${XYZ}$ (:, s - 1)) + d_cbL_${XYZ}$ (0, s - 1) = 0._wp; d_cbL_${XYZ}$ (:, s - 1) = d_cbL_${XYZ}$ (:, & + & s - 1)/sum(d_cbL_${XYZ}$ (:, s - 1)) d_cbR_${XYZ}$ (0:1, s) = 0._wp; d_cbR_${XYZ}$ (2, s) = 1._wp d_cbL_${XYZ}$ (0:1, s) = 0._wp; d_cbL_${XYZ}$ (2, s) = 1._wp end if end if - else ! WENO7 if (.not. teno) then - do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn - - ! Reference: Shu (1997) "Essentially Non-Oscillatory and Weighted Essentially Non-Oscillatory Schemes for Hyperbolic Conservation Laws" + ! Reference: Shu (1997) "Essentially Non-Oscillatory and Weighted Essentially Non-Oscillatory Schemes + ! for Hyperbolic Conservation Laws" ! Equation 2.20: Polynomial Coefficients (poly_coef_cb) ! Equation 2.61: Smoothness Indicators (beta_coef) - ! To reduce computational cost, we leverage the fact that all polynomial coefficients in a stencil sum to 1 - ! and compute the polynomial coefficients (poly_coef_cb) for the cell value differences (dvd) instead of the values themselves. - ! The computation of coefficients is further simplified by using grid spacing (y or w) rather than the grid locations (s_cb) directly. - ! Ideal weights (d_cb) are obtained by comparing the grid location coefficients of the polynomial coefficients. - ! The smoothness indicators (beta_coef) are calculated through numerical differentiation and integration of each cross term of the polynomial coefficients, + ! To reduce computational cost, we leverage the fact that all polynomial coefficients in a stencil sum + ! to 1 + ! and compute the polynomial coefficients (poly_coef_cb) for the cell value differences (dvd) instead of + ! the values themselves. + ! The computation of coefficients is further simplified by using grid spacing (y or w) rather than the + ! grid locations (s_cb) directly. + ! Ideal weights (d_cb) are obtained by comparing the grid location coefficients of the polynomial + ! coefficients. + ! The smoothness indicators (beta_coef) are calculated through numerical differentiation and integration + ! of each cross term of the polynomial coefficients, ! using the cell value differences (dvd) instead of the values themselves. - ! While the polynomial coefficients sum to 1, the derivative of 1 is 0, which means it does not create additional cross terms in the smoothness indicators. + ! While the polynomial coefficients sum to 1, the derivative of 1 is 0, which means it does not create + ! additional cross terms in the smoothness indicators. w = s_cb(i - 3:i + 4) - s_cb(i) ! Offset using s_cb(i) to reduce floating point error - d_cbR_${XYZ}$ (0, i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))) !& - d_cbR_${XYZ}$ (1, i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1)*w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7)*w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))) !& - d_cbR_${XYZ}$ (2, i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2)*w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7)*w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))*(w(3) - w(8))) !& - d_cbR_${XYZ}$ (3, i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8))*(w(3) - w(8))) !& + d_cbR_${XYZ}$ (0, & + & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & + & *(w(1) - w(8))) !& + d_cbR_${XYZ}$ (1, & + & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1) & + & *w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7) & + & *w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7)) & + & *(w(2) - w(8))) !& + d_cbR_${XYZ}$ (2, & + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2) & + & *w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7) & + & *w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8)) & + & *(w(3) - w(8))) !& + d_cbR_${XYZ}$ (3, & + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8)) & + & *(w(3) - w(8))) !& w = s_cb(i + 4:i - 3:-1) - s_cb(i) - d_cbL_${XYZ}$ (0, i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8))*(w(3) - w(8))) !& - d_cbL_${XYZ}$ (1, i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2)*w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7)*w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))*(w(3) - w(8))) !& - d_cbL_${XYZ}$ (2, i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1)*w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7)*w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))) !& - d_cbL_${XYZ}$ (3, i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))) !& + d_cbL_${XYZ}$ (0, & + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8)) & + & *(w(3) - w(8))) !& + d_cbL_${XYZ}$ (1, & + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2) & + & *w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7) & + & *w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8)) & + & *(w(3) - w(8))) !& + d_cbL_${XYZ}$ (2, & + & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1) & + & *w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7) & + & *w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7)) & + & *(w(2) - w(8))) !& + d_cbL_${XYZ}$ (3, & + & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & + & *(w(1) - w(8))) !& ! Note: Left has the reversed order of both points and coefficients compared to the right y = s_cb(i + 1:i + 4) - s_cb(i:i + 3) - poly_coef_cbR_${XYZ}$ (i + 1, 0, 0) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbR_${XYZ}$ (i + 1, 0, 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbR_${XYZ}$ (i + 1, 0, 2) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 0, & + & 0) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 0, & + & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) & + & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 0, & + & 2) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & + & + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) & + & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i:i + 3) - s_cb(i - 1:i + 2) - poly_coef_cbR_${XYZ}$ (i + 1, 1, 0) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbR_${XYZ}$ (i + 1, 1, 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbR_${XYZ}$ (i + 1, 1, 2) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 1, & + & 0) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 1, & + & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) & + & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 1, & + & 2) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & + & + y(2) + y(3) + y(4))) !& y = s_cb(i - 1:i + 2) - s_cb(i - 2:i + 1) - poly_coef_cbR_${XYZ}$ (i + 1, 2, 0) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbR_${XYZ}$ (i + 1, 2, 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbR_${XYZ}$ (i + 1, 2, 2) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 2, & + & 0) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 2, & + & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & + & + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) & + & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 2, & + & 2) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & + & + y(2) + y(3) + y(4))) !& y = s_cb(i - 2:i + 1) - s_cb(i - 3:i) - poly_coef_cbR_${XYZ}$ (i + 1, 3, 0) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbR_${XYZ}$ (i + 1, 3, 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbR_${XYZ}$ (i + 1, 3, 2) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 3, & + & 0) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 & + & + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) & + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 3, & + & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) & + & + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2)) & + & /((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))) !& + poly_coef_cbR_${XYZ}$ (i + 1, 3, & + & 2) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) & + & + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i + 1:i - 2:-1) - s_cb(i:i - 3:-1) - poly_coef_cbL_${XYZ}$ (i + 1, 3, 2) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbL_${XYZ}$ (i + 1, 3, 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbL_${XYZ}$ (i + 1, 3, 0) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 3, & + & 2) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 3, & + & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) & + & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 3, & + & 0) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & + & + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) & + & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i + 2:i - 1:-1) - s_cb(i + 1:i - 2:-1) - poly_coef_cbL_${XYZ}$ (i + 1, 2, 2) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbL_${XYZ}$ (i + 1, 2, 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbL_${XYZ}$ (i + 1, 2, 0) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 2, & + & 2) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 2, & + & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) & + & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 2, & + & 0) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & + & + y(2) + y(3) + y(4))) !& y = s_cb(i + 3:i:-1) - s_cb(i + 2:i - 1:-1) - poly_coef_cbL_${XYZ}$ (i + 1, 1, 2) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbL_${XYZ}$ (i + 1, 1, 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbL_${XYZ}$ (i + 1, 1, 0) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 1, & + & 2) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 1, & + & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & + & + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) & + & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 1, & + & 0) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & + & + y(2) + y(3) + y(4))) !& y = s_cb(i + 4:i + 1:-1) - s_cb(i + 3:i:-1) - poly_coef_cbL_${XYZ}$ (i + 1, 0, 2) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbL_${XYZ}$ (i + 1, 0, 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& - poly_coef_cbL_${XYZ}$ (i + 1, 0, 0) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& - - poly_coef_cbL_${XYZ}$ (i + 1, :, :) = -poly_coef_cbL_${XYZ}$ (i + 1, :, :) + poly_coef_cbL_${XYZ}$ (i + 1, 0, & + & 2) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 & + & + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) & + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 0, & + & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) & + & + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2)) & + & /((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))) !& + poly_coef_cbL_${XYZ}$ (i + 1, 0, & + & 0) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) & + & + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + + poly_coef_cbL_${XYZ}$ (i + 1,:,:) = -poly_coef_cbL_${XYZ}$ (i + 1,:,:) ! Note: negative sign as the direction of taking the difference (dvd) is reversed y = s_cb(i - 2:i + 1) - s_cb(i - 3:i) - beta_coef_${XYZ}$ (i + 1, 3, 0) = (4*y(4)**2*(5*y(1)**2*y(2)**2 + 20*y(1)**2*y(2)*y(3) + 15*y(1)**2*y(2)*y(4) + 20*y(1)**2*y(3)**2 + 30*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 10*y(1)*y(2)**3 + 60*y(1)*y(2)**2*y(3) + 45*y(1)*y(2)**2*y(4) + 110*y(1)*y(2)*y(3)**2 + 165*y(1)*y(2)*y(3)*y(4) & !& - + 260*y(1)*y(2)*y(4)**2 + 60*y(1)*y(3)**3 + 135*y(1)*y(3)**2*y(4) + 400*y(1)*y(3)*y(4)**2 + 225*y(1)*y(4)**3 + 5*y(2)**4 + 40*y(2)**3*y(3) + 30*y(2)**3*y(4) + 110*y(2)**2*y(3)**2 + 165*y(2)**2*y(3)*y(4) + 260*y(2)**2*y(4)**2 + 120*y(2)*y(3)**3 & !& - + 270*y(2)*y(3)**2*y(4) + 800*y(2)*y(3)*y(4)**2 + 450*y(2)*y(4)**3 + 45*y(3)**4 + 135*y(3)**3*y(4) + 600*y(3)**2*y(4)**2 + 675*y(3)*y(4)**3 + 996*y(4)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 3, 1) = -(4*y(4)**2*(10*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1)**3*y(3)**2 + 25*y(1)**3*y(3)*y(4) + 105*y(1)**3*y(4)**2 + 40*y(1)**2*y(2)**2*y(3) + 20*y(1)**2*y(2)**2*y(4) + 130*y(1)**2*y(2)*y(3)**2 + 155*y(1)**2*y(2)*y(3)*y(4) + 535*y(1)**2*y(2)*y(4)**2 & !& - + 90*y(1)**2*y(3)**3 + 165*y(1)**2*y(3)**2*y(4) + 790*y(1)**2*y(3)*y(4)**2 + 415*y(1)**2*y(4)**3 + 60*y(1)*y(2)**3*y(3) + 30*y(1)*y(2)**3*y(4) + 270*y(1)*y(2)**2*y(3)**2 + 315*y(1)*y(2)**2*y(3)*y(4) + 975*y(1)*y(2)**2*y(4)**2 + 360*y(1)*y(2)*y(3)**3 & !& - + 645*y(1)*y(2)*y(3)**2*y(4) + 2850*y(1)*y(2)*y(3)*y(4)**2 + 1460*y(1)*y(2)*y(4)**3 + 150*y(1)*y(3)**4 + 360*y(1)*y(3)**3*y(4) + 2000*y(1)*y(3)**2*y(4)**2 + 2005*y(1)*y(3)*y(4)**3 + 2077*y(1)*y(4)**4 + 30*y(2)**4*y(3) + 15*y(2)**4*y(4) + 180*y(2)**3*y(3)**2 & !& - + 210*y(2)**3*y(3)*y(4) + 650*y(2)**3*y(4)**2 + 360*y(2)**2*y(3)**3 + 645*y(2)**2*y(3)**2*y(4) + 2850*y(2)**2*y(3)*y(4)**2 + 1460*y(2)**2*y(4)**3 + 300*y(2)*y(3)**4 + 720*y(2)*y(3)**3*y(4) + 4000*y(2)*y(3)**2*y(4)**2 + 4010*y(2)*y(3)*y(4)**3 + 4154*y(2)*y(4)**4 & !& - + 90*y(3)**5 + 270*y(3)**4*y(4) + 1800*y(3)**3*y(4)**2 + 2655*y(3)**2*y(4)**3 + 4464*y(3)*y(4)**4 + 1767*y(4)**5))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 3, 2) = (4*y(4)**2*(10*y(2)**3*y(3) + 5*y(2)**3*y(4) + 50*y(2)**2*y(3)**2 + 60*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)**2*y(3) + 215*y(2)**2*y(4)**2 + 5*y(1)*y(2)**2*y(4) + 70*y(2)*y(3)**3 + 130*y(2)*y(3)**2*y(4) + 30*y(1)*y(2)*y(3)**2 + 775*y(2)*y(3)*y(4)**2 & !& - + 35*y(1)*y(2)*y(3)*y(4) + 415*y(2)*y(4)**3 + 110*y(1)*y(2)*y(4)**2 + 30*y(3)**4 + 75*y(3)**3*y(4) + 20*y(1)*y(3)**3 + 665*y(3)**2*y(4)**2 + 35*y(1)*y(3)**2*y(4) + 725*y(3)*y(4)**3 + 220*y(1)*y(3)*y(4)**2 + 1767*y(4)**4 + 105*y(1)*y(4)**3)) & !& - /(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 3, 3) = (4*y(4)**2*(5*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 50*y(1)**4*y(4)**2 + 30*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 300*y(1)**3*y(2)*y(4)**2 + 30*y(1)**3*y(3)**3 + 45*y(1)**3*y(3)**2*y(4) + 415*y(1)**3*y(3)*y(4)**2 + 200*y(1)**3*y(4)**3 & !& - + 75*y(1)**2*y(2)**2*y(3)**2 + 75*y(1)**2*y(2)**2*y(3)*y(4) + 750*y(1)**2*y(2)**2*y(4)**2 + 150*y(1)**2*y(2)*y(3)**3 + 225*y(1)**2*y(2)*y(3)**2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 1000*y(1)**2*y(2)*y(4)**3 + 75*y(1)**2*y(3)**4 + 150*y(1)**2*y(3)**3*y(4) & !& - + 1390*y(1)**2*y(3)**2*y(4)**2 + 1315*y(1)**2*y(3)*y(4)**3 + 1081*y(1)**2*y(4)**4 + 90*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2)**3*y(3)*y(4) + 900*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1)*y(2)**2*y(3)**2*y(4) + 3735*y(1)*y(2)**2*y(3)*y(4)**2 & !& - + 1800*y(1)*y(2)**2*y(4)**3 + 270*y(1)*y(2)*y(3)**4 + 540*y(1)*y(2)*y(3)**3*y(4) + 5025*y(1)*y(2)*y(3)**2*y(4)**2 + 4755*y(1)*y(2)*y(3)*y(4)**3 + 4224*y(1)*y(2)*y(4)**4 + 90*y(1)*y(3)**5 + 225*y(1)*y(3)**4*y(4) + 2190*y(1)*y(3)**3*y(4)**2 + 3060*y(1)*y(3)**2*y(4)**3 & !& - + 4529*y(1)*y(3)*y(4)**4 + 1762*y(1)*y(4)**5 + 45*y(2)**4*y(3)**2 + 45*y(2)**4*y(3)*y(4) + 450*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3)**2*y(4) + 2490*y(2)**3*y(3)*y(4)**2 + 1200*y(2)**3*y(4)**3 + 270*y(2)**2*y(3)**4 + 540*y(2)**2*y(3)**3*y(4) & !& - + 5025*y(2)**2*y(3)**2*y(4)**2 + 4755*y(2)**2*y(3)*y(4)**3 + 4224*y(2)**2*y(4)**4 + 180*y(2)*y(3)**5 + 450*y(2)*y(3)**4*y(4) + 4380*y(2)*y(3)**3*y(4)**2 + 6120*y(2)*y(3)**2*y(4)**3 + 9058*y(2)*y(3)*y(4)**4 + 3524*y(2)*y(4)**5 + 45*y(3)**6 + 135*y(3)**5*y(4) & !& - + 1395*y(3)**4*y(4)**2 + 2565*y(3)**3*y(4)**3 + 4884*y(3)**2*y(4)**4 + 3624*y(3)*y(4)**5 + 831*y(4)**6))/(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 3, 4) = -(4*y(4)**2*(10*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 100*y(1)**2*y(2)*y(4)**2 + 10*y(1)**2*y(3)**3 + 15*y(1)**2*y(3)**2*y(4) + 205*y(1)**2*y(3)*y(4)**2 + 100*y(1)**2*y(4)**3 + 30*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2)**2*y(3)*y(4) & !& - + 300*y(1)*y(2)**2*y(4)**2 + 60*y(1)*y(2)*y(3)**3 + 90*y(1)*y(2)*y(3)**2*y(4) + 1030*y(1)*y(2)*y(3)*y(4)**2 + 500*y(1)*y(2)*y(4)**3 + 30*y(1)*y(3)**4 + 60*y(1)*y(3)**3*y(4) + 835*y(1)*y(3)**2*y(4)**2 + 805*y(1)*y(3)*y(4)**3 + 1762*y(1)*y(4)**4 + 30*y(2)**3*y(3)**2 & !& - + 30*y(2)**3*y(3)*y(4) + 300*y(2)**3*y(4)**2 + 90*y(2)**2*y(3)**3 + 135*y(2)**2*y(3)**2*y(4) + 1445*y(2)**2*y(3)*y(4)**2 + 700*y(2)**2*y(4)**3 + 90*y(2)*y(3)**4 + 180*y(2)*y(3)**3*y(4) + 2205*y(2)*y(3)**2*y(4)**2 + 2115*y(2)*y(3)*y(4)**3 + 3624*y(2)*y(4)**4 & !& - + 30*y(3)**5 + 75*y(3)**4*y(4) + 1060*y(3)**3*y(4)**2 + 1515*y(3)**2*y(4)**3 + 3824*y(3)*y(4)**4 + 1662*y(4)**5))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 3, 5) = (4*y(4)**2*(5*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 + 15*y(2)*y(3)**2*y(4) + 205*y(2)*y(3)*y(4)**2 + 100*y(2)*y(4)**3 + 5*y(3)**4 + 10*y(3)**3*y(4) + 205*y(3)**2*y(4)**2 + 200*y(3)*y(4)**3 + 831*y(4)**4))/(5*(y(1) & !& - + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 3, & + & 0) = (4*y(4)**2*(5*y(1)**2*y(2)**2 + 20*y(1)**2*y(2)*y(3) + 15*y(1)**2*y(2)*y(4) & + & + 20*y(1)**2*y(3)**2 + 30*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 10*y(1)*y(2) & + & **3 + 60*y(1)*y(2)**2*y(3) + 45*y(1)*y(2)**2*y(4) + 110*y(1)*y(2)*y(3)**2 & + & + 165*y(1)*y(2)*y(3)*y(4) + 260*y(1)*y(2)*y(4)**2 + 60*y(1)*y(3)**3 + 135*y(1) & + & *y(3)**2*y(4) + 400*y(1)*y(3)*y(4)**2 + 225*y(1)*y(4)**3 + 5*y(2)**4 + 40*y(2) & + & **3*y(3) + 30*y(2)**3*y(4) + 110*y(2)**2*y(3)**2 + 165*y(2)**2*y(3)*y(4) & + & + 260*y(2)**2*y(4)**2 + 120*y(2)*y(3)**3 + 270*y(2)*y(3)**2*y(4) + 800*y(2)*y(3) & + & *y(4)**2 + 450*y(2)*y(4)**3 + 45*y(3)**4 + 135*y(3)**3*y(4) + 600*y(3)**2*y(4) & + & **2 + 675*y(3)*y(4)**3 + 996*y(4)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4)) & + & **2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 3, & + & 1) = -(4*y(4)**2*(10*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1)**3*y(3) & + & **2 + 25*y(1)**3*y(3)*y(4) + 105*y(1)**3*y(4)**2 + 40*y(1)**2*y(2)**2*y(3) & + & + 20*y(1)**2*y(2)**2*y(4) + 130*y(1)**2*y(2)*y(3)**2 + 155*y(1)**2*y(2)*y(3)*y(4) & + & + 535*y(1)**2*y(2)*y(4)**2 + 90*y(1)**2*y(3)**3 + 165*y(1)**2*y(3)**2*y(4) & + & + 790*y(1)**2*y(3)*y(4)**2 + 415*y(1)**2*y(4)**3 + 60*y(1)*y(2)**3*y(3) + 30*y(1) & + & *y(2)**3*y(4) + 270*y(1)*y(2)**2*y(3)**2 + 315*y(1)*y(2)**2*y(3)*y(4) + 975*y(1) & + & *y(2)**2*y(4)**2 + 360*y(1)*y(2)*y(3)**3 + 645*y(1)*y(2)*y(3)**2*y(4) + 2850*y(1) & + & *y(2)*y(3)*y(4)**2 + 1460*y(1)*y(2)*y(4)**3 + 150*y(1)*y(3)**4 + 360*y(1)*y(3) & + & **3*y(4) + 2000*y(1)*y(3)**2*y(4)**2 + 2005*y(1)*y(3)*y(4)**3 + 2077*y(1)*y(4) & + & **4 + 30*y(2)**4*y(3) + 15*y(2)**4*y(4) + 180*y(2)**3*y(3)**2 + 210*y(2)**3*y(3) & + & *y(4) + 650*y(2)**3*y(4)**2 + 360*y(2)**2*y(3)**3 + 645*y(2)**2*y(3)**2*y(4) & + & + 2850*y(2)**2*y(3)*y(4)**2 + 1460*y(2)**2*y(4)**3 + 300*y(2)*y(3)**4 + 720*y(2) & + & *y(3)**3*y(4) + 4000*y(2)*y(3)**2*y(4)**2 + 4010*y(2)*y(3)*y(4)**3 + 4154*y(2) & + & *y(4)**4 + 90*y(3)**5 + 270*y(3)**4*y(4) + 1800*y(3)**3*y(4)**2 + 2655*y(3) & + & **2*y(4)**3 + 4464*y(3)*y(4)**4 + 1767*y(4)**5))/(5*(y(2) + y(3))*(y(3) + y(4)) & + & *(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 3, & + & 2) = (4*y(4)**2*(10*y(2)**3*y(3) + 5*y(2)**3*y(4) + 50*y(2)**2*y(3)**2 + 60*y(2) & + & **2*y(3)*y(4) + 10*y(1)*y(2)**2*y(3) + 215*y(2)**2*y(4)**2 + 5*y(1)*y(2)**2*y(4) & + & + 70*y(2)*y(3)**3 + 130*y(2)*y(3)**2*y(4) + 30*y(1)*y(2)*y(3)**2 + 775*y(2)*y(3) & + & *y(4)**2 + 35*y(1)*y(2)*y(3)*y(4) + 415*y(2)*y(4)**3 + 110*y(1)*y(2)*y(4)**2 & + & + 30*y(3)**4 + 75*y(3)**3*y(4) + 20*y(1)*y(3)**3 + 665*y(3)**2*y(4)**2 + 35*y(1) & + & *y(3)**2*y(4) + 725*y(3)*y(4)**3 + 220*y(1)*y(3)*y(4)**2 + 1767*y(4)**4 & + & + 105*y(1)*y(4)**3))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 3, & + & 3) = (4*y(4)**2*(5*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 50*y(1)**4*y(4)**2 & + & + 30*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 300*y(1)**3*y(2)*y(4)**2 & + & + 30*y(1)**3*y(3)**3 + 45*y(1)**3*y(3)**2*y(4) + 415*y(1)**3*y(3)*y(4)**2 & + & + 200*y(1)**3*y(4)**3 + 75*y(1)**2*y(2)**2*y(3)**2 + 75*y(1)**2*y(2)**2*y(3)*y(4) & + & + 750*y(1)**2*y(2)**2*y(4)**2 + 150*y(1)**2*y(2)*y(3)**3 + 225*y(1)**2*y(2)*y(3) & + & **2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 1000*y(1)**2*y(2)*y(4)**3 + 75*y(1) & + & **2*y(3)**4 + 150*y(1)**2*y(3)**3*y(4) + 1390*y(1)**2*y(3)**2*y(4)**2 + 1315*y(1) & + & **2*y(3)*y(4)**3 + 1081*y(1)**2*y(4)**4 + 90*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2) & + & **3*y(3)*y(4) + 900*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1) & + & *y(2)**2*y(3)**2*y(4) + 3735*y(1)*y(2)**2*y(3)*y(4)**2 + 1800*y(1)*y(2)**2*y(4) & + & **3 + 270*y(1)*y(2)*y(3)**4 + 540*y(1)*y(2)*y(3)**3*y(4) + 5025*y(1)*y(2)*y(3) & + & **2*y(4)**2 + 4755*y(1)*y(2)*y(3)*y(4)**3 + 4224*y(1)*y(2)*y(4)**4 + 90*y(1)*y(3) & + & **5 + 225*y(1)*y(3)**4*y(4) + 2190*y(1)*y(3)**3*y(4)**2 + 3060*y(1)*y(3)**2*y(4) & + & **3 + 4529*y(1)*y(3)*y(4)**4 + 1762*y(1)*y(4)**5 + 45*y(2)**4*y(3)**2 + 45*y(2) & + & **4*y(3)*y(4) + 450*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3) & + & **2*y(4) + 2490*y(2)**3*y(3)*y(4)**2 + 1200*y(2)**3*y(4)**3 + 270*y(2)**2*y(3) & + & **4 + 540*y(2)**2*y(3)**3*y(4) + 5025*y(2)**2*y(3)**2*y(4)**2 + 4755*y(2)**2*y(3) & + & *y(4)**3 + 4224*y(2)**2*y(4)**4 + 180*y(2)*y(3)**5 + 450*y(2)*y(3)**4*y(4) & + & + 4380*y(2)*y(3)**3*y(4)**2 + 6120*y(2)*y(3)**2*y(4)**3 + 9058*y(2)*y(3)*y(4)**4 & + & + 3524*y(2)*y(4)**5 + 45*y(3)**6 + 135*y(3)**5*y(4) + 1395*y(3)**4*y(4)**2 & + & + 2565*y(3)**3*y(4)**3 + 4884*y(3)**2*y(4)**4 + 3624*y(3)*y(4)**5 + 831*y(4)**6)) & + & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 3, & + & 4) = -(4*y(4)**2*(10*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 100*y(1) & + & **2*y(2)*y(4)**2 + 10*y(1)**2*y(3)**3 + 15*y(1)**2*y(3)**2*y(4) + 205*y(1) & + & **2*y(3)*y(4)**2 + 100*y(1)**2*y(4)**3 + 30*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2) & + & **2*y(3)*y(4) + 300*y(1)*y(2)**2*y(4)**2 + 60*y(1)*y(2)*y(3)**3 + 90*y(1)*y(2) & + & *y(3)**2*y(4) + 1030*y(1)*y(2)*y(3)*y(4)**2 + 500*y(1)*y(2)*y(4)**3 + 30*y(1) & + & *y(3)**4 + 60*y(1)*y(3)**3*y(4) + 835*y(1)*y(3)**2*y(4)**2 + 805*y(1)*y(3)*y(4) & + & **3 + 1762*y(1)*y(4)**4 + 30*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 300*y(2) & + & **3*y(4)**2 + 90*y(2)**2*y(3)**3 + 135*y(2)**2*y(3)**2*y(4) + 1445*y(2)**2*y(3) & + & *y(4)**2 + 700*y(2)**2*y(4)**3 + 90*y(2)*y(3)**4 + 180*y(2)*y(3)**3*y(4) & + & + 2205*y(2)*y(3)**2*y(4)**2 + 2115*y(2)*y(3)*y(4)**3 + 3624*y(2)*y(4)**4 & + & + 30*y(3)**5 + 75*y(3)**4*y(4) + 1060*y(3)**3*y(4)**2 + 1515*y(3)**2*y(4)**3 & + & + 3824*y(3)*y(4)**4 + 1662*y(4)**5))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) & + & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 3, & + & 5) = (4*y(4)**2*(5*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 & + & + 10*y(2)*y(3)**3 + 15*y(2)*y(3)**2*y(4) + 205*y(2)*y(3)*y(4)**2 + 100*y(2)*y(4) & + & **3 + 5*y(3)**4 + 10*y(3)**3*y(4) + 205*y(3)**2*y(4)**2 + 200*y(3)*y(4)**3 & + & + 831*y(4)**4))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) & + & + y(4))**2) !& y = s_cb(i - 1:i + 2) - s_cb(i - 2:i + 1) - beta_coef_${XYZ}$ (i + 1, 2, 0) = (4*y(3)**2*(5*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 + 15*y(1)*y(2)**2*y(3) + 205*y(1)*y(2)*y(3)**2 + 100*y(1)*y(3)**3 + 5*y(2)**4 + 10*y(2)**3*y(3) + 205*y(2)**2*y(3)**2 + 200*y(2)*y(3)**3 + 831*y(3)**4))/(5*(y(3) & !& - + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 2, 1) = (4*y(3)**2*(5*y(1)**3*y(2)*y(3) + 10*y(1)**3*y(2)*y(4) - 95*y(1)**3*y(3)**2 + 5*y(1)**3*y(3)*y(4) + 20*y(1)**2*y(2)**2*y(3) + 40*y(1)**2*y(2)**2*y(4) - 465*y(1)**2*y(2)*y(3)**2 + 55*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4)**2 - 285*y(1)**2*y(3)**3 & !& - + 20*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 30*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) - 825*y(1)*y(2)**2*y(3)**2 + 135*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 - 1040*y(1)*y(2)*y(3)**3 + 100*y(1)*y(2)*y(3)**2*y(4) + 35*y(1)*y(2)*y(3)*y(4)**2 & !& - - 1847*y(1)*y(3)**4 + 125*y(1)*y(3)**3*y(4) + 110*y(1)*y(3)**2*y(4)**2 + 15*y(2)**4*y(3) + 30*y(2)**4*y(4) - 550*y(2)**3*y(3)**2 + 90*y(2)**3*y(3)*y(4) + 20*y(2)**3*y(4)**2 - 1040*y(2)**2*y(3)**3 + 100*y(2)**2*y(3)**2*y(4) + 35*y(2)**2*y(3)*y(4)**2 & !& - - 3694*y(2)*y(3)**4 + 250*y(2)*y(3)**3*y(4) + 220*y(2)*y(3)**2*y(4)**2 - 3219*y(3)**5 - 1452*y(3)**4*y(4) + 105*y(3)**3*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 2, 2) = -(4*y(3)**2*(5*y(2)**3*y(3) - 95*y(2)*y(3)**3 - 190*y(2)**2*y(3)**2 + 10*y(2)**3*y(4) + 100*y(3)**3*y(4) - 1562*y(3)**4 - 95*y(1)*y(2)*y(3)**2 + 5*y(1)*y(2)**2*y(3) + 10*y(1)*y(2)**2*y(4) + 100*y(1)*y(3)**2*y(4) + 205*y(2)*y(3)**2*y(4) & !& - + 15*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 2, 3) = (4*y(3)**2*(50*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 300*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 30*y(1)**3*y(2)*y(4)**2 + 200*y(1)**3*y(3)**3 + 25*y(1)**3*y(3)**2*y(4) + 35*y(1)**3*y(3)*y(4)**2 + 10*y(1)**3*y(4)**3 & !& - + 750*y(1)**2*y(2)**2*y(3)**2 + 75*y(1)**2*y(2)**2*y(3)*y(4) + 75*y(1)**2*y(2)**2*y(4)**2 + 1000*y(1)**2*y(2)*y(3)**3 + 125*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 + 50*y(1)**2*y(2)*y(4)**3 + 1081*y(1)**2*y(3)**4 - 50*y(1)**2*y(3)**3*y(4) & !& - - 10*y(1)**2*y(3)**2*y(4)**2 + 45*y(1)**2*y(3)*y(4)**3 + 5*y(1)**2*y(4)**4 + 900*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2)**3*y(3)*y(4) + 90*y(1)*y(2)**3*y(4)**2 + 1800*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) + 315*y(1)*y(2)**2*y(3)*y(4)**2 & !& - + 90*y(1)*y(2)**2*y(4)**3 + 4224*y(1)*y(2)*y(3)**4 - 120*y(1)*y(2)*y(3)**3*y(4) + 25*y(1)*y(2)*y(3)**2*y(4)**2 + 165*y(1)*y(2)*y(3)*y(4)**3 + 20*y(1)*y(2)*y(4)**4 + 3324*y(1)*y(3)**5 + 1407*y(1)*y(3)**4*y(4) - 100*y(1)*y(3)**3*y(4)**2 + 70*y(1)*y(3)**2*y(4)**3 & !& - + 15*y(1)*y(3)*y(4)**4 + 450*y(2)**4*y(3)**2 + 45*y(2)**4*y(3)*y(4) + 45*y(2)**4*y(4)**2 + 1200*y(2)**3*y(3)**3 + 150*y(2)**3*y(3)**2*y(4) + 210*y(2)**3*y(3)*y(4)**2 + 60*y(2)**3*y(4)**3 + 4224*y(2)**2*y(3)**4 - 120*y(2)**2*y(3)**3*y(4) + 25*y(2)**2*y(3)**2*y(4)**2 & !& - + 165*y(2)**2*y(3)*y(4)**3 + 20*y(2)**2*y(4)**4 + 6648*y(2)*y(3)**5 + 2814*y(2)*y(3)**4*y(4) - 200*y(2)*y(3)**3*y(4)**2 + 140*y(2)*y(3)**2*y(4)**3 + 30*y(2)*y(3)*y(4)**4 + 3174*y(3)**6 + 3039*y(3)**5*y(4) + 771*y(3)**4*y(4)**2 + 135*y(3)**3*y(4)**3 + 60*y(3)**2*y(4)**4)) & !& - /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 2, 4) = -(4*y(3)**2*(100*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4)**2 - 95*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 300*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 + 200*y(1)*y(2)*y(3)**3 & !& - - 260*y(1)*y(2)*y(3)**2*y(4) + 50*y(1)*y(2)*y(3)*y(4)**2 + 10*y(1)*y(2)*y(4)**3 + 1562*y(1)*y(3)**4 - 190*y(1)*y(3)**3*y(4) + 15*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4)**3 + 300*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 30*y(2)**3*y(4)**2 + 400*y(2)**2*y(3)**3 & !& - - 235*y(2)**2*y(3)**2*y(4) + 85*y(2)**2*y(3)*y(4)**2 + 20*y(2)**2*y(4)**3 + 3224*y(2)*y(3)**4 - 460*y(2)*y(3)**3*y(4) - 35*y(2)*y(3)**2*y(4)**2 + 25*y(2)*y(3)*y(4)**3 + 3124*y(3)**5 + 1467*y(3)**4*y(4) + 110*y(3)**3*y(4)**2 + 105*y(3)**2*y(4)**3)) & !& - /(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 2, 5) = (4*y(3)**2*(50*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 5*y(2)**2*y(4)**2 - 95*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 781*y(3)**4 + 50*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 2, & + & 0) = (4*y(3)**2*(5*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 & + & + 10*y(1)*y(2)**3 + 15*y(1)*y(2)**2*y(3) + 205*y(1)*y(2)*y(3)**2 + 100*y(1)*y(3) & + & **3 + 5*y(2)**4 + 10*y(2)**3*y(3) + 205*y(2)**2*y(3)**2 + 200*y(2)*y(3)**3 & + & + 831*y(3)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) & + & + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 2, & + & 1) = (4*y(3)**2*(5*y(1)**3*y(2)*y(3) + 10*y(1)**3*y(2)*y(4) - 95*y(1)**3*y(3)**2 & + & + 5*y(1)**3*y(3)*y(4) + 20*y(1)**2*y(2)**2*y(3) + 40*y(1)**2*y(2)**2*y(4) & + & - 465*y(1)**2*y(2)*y(3)**2 + 55*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4)**2 & + & - 285*y(1)**2*y(3)**3 + 20*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 & + & + 30*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) - 825*y(1)*y(2)**2*y(3)**2 & + & + 135*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 - 1040*y(1)*y(2)*y(3)**3 & + & + 100*y(1)*y(2)*y(3)**2*y(4) + 35*y(1)*y(2)*y(3)*y(4)**2 - 1847*y(1)*y(3)**4 & + & + 125*y(1)*y(3)**3*y(4) + 110*y(1)*y(3)**2*y(4)**2 + 15*y(2)**4*y(3) + 30*y(2) & + & **4*y(4) - 550*y(2)**3*y(3)**2 + 90*y(2)**3*y(3)*y(4) + 20*y(2)**3*y(4)**2 & + & - 1040*y(2)**2*y(3)**3 + 100*y(2)**2*y(3)**2*y(4) + 35*y(2)**2*y(3)*y(4)**2 & + & - 3694*y(2)*y(3)**4 + 250*y(2)*y(3)**3*y(4) + 220*y(2)*y(3)**2*y(4)**2 & + & - 3219*y(3)**5 - 1452*y(3)**4*y(4) + 105*y(3)**3*y(4)**2))/(5*(y(2) + y(3))*(y(3) & + & + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4)) & + & **2) !& + beta_coef_${XYZ}$ (i + 1, 2, & + & 2) = -(4*y(3)**2*(5*y(2)**3*y(3) - 95*y(2)*y(3)**3 - 190*y(2)**2*y(3)**2 & + & + 10*y(2)**3*y(4) + 100*y(3)**3*y(4) - 1562*y(3)**4 - 95*y(1)*y(2)*y(3)**2 & + & + 5*y(1)*y(2)**2*y(3) + 10*y(1)*y(2)**2*y(4) + 100*y(1)*y(3)**2*y(4) + 205*y(2) & + & *y(3)**2*y(4) + 15*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2)) & + & *(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 2, & + & 3) = (4*y(3)**2*(50*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 & + & + 300*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 30*y(1)**3*y(2)*y(4)**2 & + & + 200*y(1)**3*y(3)**3 + 25*y(1)**3*y(3)**2*y(4) + 35*y(1)**3*y(3)*y(4)**2 & + & + 10*y(1)**3*y(4)**3 + 750*y(1)**2*y(2)**2*y(3)**2 + 75*y(1)**2*y(2)**2*y(3)*y(4) & + & + 75*y(1)**2*y(2)**2*y(4)**2 + 1000*y(1)**2*y(2)*y(3)**3 + 125*y(1)**2*y(2)*y(3) & + & **2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 + 50*y(1)**2*y(2)*y(4)**3 + 1081*y(1) & + & **2*y(3)**4 - 50*y(1)**2*y(3)**3*y(4) - 10*y(1)**2*y(3)**2*y(4)**2 + 45*y(1) & + & **2*y(3)*y(4)**3 + 5*y(1)**2*y(4)**4 + 900*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2) & + & **3*y(3)*y(4) + 90*y(1)*y(2)**3*y(4)**2 + 1800*y(1)*y(2)**2*y(3)**3 + 225*y(1) & + & *y(2)**2*y(3)**2*y(4) + 315*y(1)*y(2)**2*y(3)*y(4)**2 + 90*y(1)*y(2)**2*y(4)**3 & + & + 4224*y(1)*y(2)*y(3)**4 - 120*y(1)*y(2)*y(3)**3*y(4) + 25*y(1)*y(2)*y(3)**2*y(4) & + & **2 + 165*y(1)*y(2)*y(3)*y(4)**3 + 20*y(1)*y(2)*y(4)**4 + 3324*y(1)*y(3)**5 & + & + 1407*y(1)*y(3)**4*y(4) - 100*y(1)*y(3)**3*y(4)**2 + 70*y(1)*y(3)**2*y(4)**3 & + & + 15*y(1)*y(3)*y(4)**4 + 450*y(2)**4*y(3)**2 + 45*y(2)**4*y(3)*y(4) + 45*y(2) & + & **4*y(4)**2 + 1200*y(2)**3*y(3)**3 + 150*y(2)**3*y(3)**2*y(4) + 210*y(2)**3*y(3) & + & *y(4)**2 + 60*y(2)**3*y(4)**3 + 4224*y(2)**2*y(3)**4 - 120*y(2)**2*y(3)**3*y(4) & + & + 25*y(2)**2*y(3)**2*y(4)**2 + 165*y(2)**2*y(3)*y(4)**3 + 20*y(2)**2*y(4)**4 & + & + 6648*y(2)*y(3)**5 + 2814*y(2)*y(3)**4*y(4) - 200*y(2)*y(3)**3*y(4)**2 & + & + 140*y(2)*y(3)**2*y(4)**3 + 30*y(2)*y(3)*y(4)**4 + 3174*y(3)**6 + 3039*y(3) & + & **5*y(4) + 771*y(3)**4*y(4)**2 + 135*y(3)**3*y(4)**3 + 60*y(3)**2*y(4)**4)) & + & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 2, & + & 4) = -(4*y(3)**2*(100*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 10*y(1) & + & **2*y(2)*y(4)**2 - 95*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 300*y(1) & + & *y(2)**2*y(3)**2 + 30*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 + 200*y(1) & + & *y(2)*y(3)**3 - 260*y(1)*y(2)*y(3)**2*y(4) + 50*y(1)*y(2)*y(3)*y(4)**2 + 10*y(1) & + & *y(2)*y(4)**3 + 1562*y(1)*y(3)**4 - 190*y(1)*y(3)**3*y(4) + 15*y(1)*y(3)**2*y(4) & + & **2 + 5*y(1)*y(3)*y(4)**3 + 300*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 30*y(2) & + & **3*y(4)**2 + 400*y(2)**2*y(3)**3 - 235*y(2)**2*y(3)**2*y(4) + 85*y(2)**2*y(3) & + & *y(4)**2 + 20*y(2)**2*y(4)**3 + 3224*y(2)*y(3)**4 - 460*y(2)*y(3)**3*y(4) & + & - 35*y(2)*y(3)**2*y(4)**2 + 25*y(2)*y(3)*y(4)**3 + 3124*y(3)**5 + 1467*y(3) & + & **4*y(4) + 110*y(3)**3*y(4)**2 + 105*y(3)**2*y(4)**3))/(5*(y(1) + y(2))*(y(2) & + & + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4)) & + & **2) !& + beta_coef_${XYZ}$ (i + 1, 2, & + & 5) = (4*y(3)**2*(50*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 5*y(2)**2*y(4)**2 & + & - 95*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 781*y(3)**4 + 50*y(3)**2*y(4)**2)) & + & /(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& y = s_cb(i:i + 3) - s_cb(i - 1:i + 2) - beta_coef_${XYZ}$ (i + 1, 1, 0) = (4*y(2)**2*(50*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 5*y(1)**2*y(3)**2 - 95*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 781*y(2)**4 + 50*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 1, 1) = -(4*y(2)**2*(105*y(1)**3*y(2)**2 + 25*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1)**3*y(3)**2 + 10*y(1)**3*y(3)*y(4) + 110*y(1)**2*y(2)**3 - 35*y(1)**2*y(2)**2*y(3) + 15*y(1)**2*y(2)**2*y(4) + 85*y(1)**2*y(2)*y(3)**2 + 50*y(1)**2*y(2)*y(3)*y(4) & !& - + 5*y(1)**2*y(2)*y(4)**2 + 30*y(1)**2*y(3)**3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 + 1467*y(1)*y(2)**4 - 460*y(1)*y(2)**3*y(3) - 190*y(1)*y(2)**3*y(4) - 235*y(1)*y(2)**2*y(3)**2 - 260*y(1)*y(2)**2*y(3)*y(4) - 95*y(1)*y(2)**2*y(4)**2 & !& - + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2)*y(3)**2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 3124*y(2)**5 + 3224*y(2)**4*y(3) + 1562*y(2)**4*y(4) + 400*y(2)**3*y(3)**2 + 200*y(2)**3*y(3)*y(4) + 300*y(2)**2*y(3)**3 + 300*y(2)**2*y(3)**2*y(4) + 100*y(2)**2*y(3)*y(4)**2)) & !& - /(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 1, 2) = -(4*y(2)**2*(100*y(1)*y(2)**3 - 190*y(2)**2*y(3)**2 + 10*y(1)*y(3)**3 + 5*y(2)*y(3)**3 - 95*y(2)**3*y(3) - 1562*y(2)**4 + 15*y(1)*y(2)*y(3)**2 + 205*y(1)*y(2)**2*y(3) + 100*y(1)*y(2)**2*y(4) + 10*y(1)*y(3)**2*y(4) + 5*y(2)*y(3)**2*y(4) - 95*y(2)**2*y(3)*y(4) & !& - + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 1, 3) = (4*y(2)**2*(60*y(1)**4*y(2)**2 + 30*y(1)**4*y(2)*y(3) + 15*y(1)**4*y(2)*y(4) + 20*y(1)**4*y(3)**2 + 20*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 135*y(1)**3*y(2)**3 + 140*y(1)**3*y(2)**2*y(3) + 70*y(1)**3*y(2)**2*y(4) + 165*y(1)**3*y(2)*y(3)**2 & !& - + 165*y(1)**3*y(2)*y(3)*y(4) + 45*y(1)**3*y(2)*y(4)**2 + 60*y(1)**3*y(3)**3 + 90*y(1)**3*y(3)**2*y(4) + 50*y(1)**3*y(3)*y(4)**2 + 10*y(1)**3*y(4)**3 + 771*y(1)**2*y(2)**4 - 200*y(1)**2*y(2)**3*y(3) - 100*y(1)**2*y(2)**3*y(4) + 25*y(1)**2*y(2)**2*y(3)**2 & !& - + 25*y(1)**2*y(2)**2*y(3)*y(4) - 10*y(1)**2*y(2)**2*y(4)**2 + 210*y(1)**2*y(2)*y(3)**3 + 315*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 + 35*y(1)**2*y(2)*y(4)**3 + 45*y(1)**2*y(3)**4 + 90*y(1)**2*y(3)**3*y(4) + 75*y(1)**2*y(3)**2*y(4)**2 & !& - + 30*y(1)**2*y(3)*y(4)**3 + 5*y(1)**2*y(4)**4 + 3039*y(1)*y(2)**5 + 2814*y(1)*y(2)**4*y(3) + 1407*y(1)*y(2)**4*y(4) - 120*y(1)*y(2)**3*y(3)**2 - 120*y(1)*y(2)**3*y(3)*y(4) - 50*y(1)*y(2)**3*y(4)**2 + 150*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) & !& - + 125*y(1)*y(2)**2*y(3)*y(4)**2 + 25*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2)*y(3)**3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1)*y(2)*y(4)**4 + 3174*y(2)**6 + 6648*y(2)**5*y(3) + 3324*y(2)**5*y(4) & !& - + 4224*y(2)**4*y(3)**2 + 4224*y(2)**4*y(3)*y(4) + 1081*y(2)**4*y(4)**2 + 1200*y(2)**3*y(3)**3 + 1800*y(2)**3*y(3)**2*y(4) + 1000*y(2)**3*y(3)*y(4)**2 + 200*y(2)**3*y(4)**3 + 450*y(2)**2*y(3)**4 + 900*y(2)**2*y(3)**3*y(4) + 750*y(2)**2*y(3)**2*y(4)**2 & !& - + 300*y(2)**2*y(3)*y(4)**3 + 50*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 1, 4) = (4*y(2)**2*(105*y(1)**2*y(2)**3 + 220*y(1)**2*y(2)**2*y(3) + 110*y(1)**2*y(2)**2*y(4) + 35*y(1)**2*y(2)*y(3)**2 + 35*y(1)**2*y(2)*y(3)*y(4) + 5*y(1)**2*y(2)*y(4)**2 + 20*y(1)**2*y(3)**3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 - 1452*y(1)*y(2)**4 & !& - + 250*y(1)*y(2)**3*y(3) + 125*y(1)*y(2)**3*y(4) + 100*y(1)*y(2)**2*y(3)**2 + 100*y(1)*y(2)**2*y(3)*y(4) + 20*y(1)*y(2)**2*y(4)**2 + 90*y(1)*y(2)*y(3)**3 + 135*y(1)*y(2)*y(3)**2*y(4) + 55*y(1)*y(2)*y(3)*y(4)**2 + 5*y(1)*y(2)*y(4)**3 + 30*y(1)*y(3)**4 & !& - + 60*y(1)*y(3)**3*y(4) + 40*y(1)*y(3)**2*y(4)**2 + 10*y(1)*y(3)*y(4)**3 - 3219*y(2)**5 - 3694*y(2)**4*y(3) - 1847*y(2)**4*y(4) - 1040*y(2)**3*y(3)**2 - 1040*y(2)**3*y(3)*y(4) - 285*y(2)**3*y(4)**2 - 550*y(2)**2*y(3)**3 - 825*y(2)**2*y(3)**2*y(4) & !& - - 465*y(2)**2*y(3)*y(4)**2 - 95*y(2)**2*y(4)**3 + 15*y(2)*y(3)**4 + 30*y(2)*y(3)**3*y(4) + 20*y(2)*y(3)**2*y(4)**2 + 5*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 1, 5) = (4*y(2)**2*(831*y(2)**4 + 200*y(2)**3*y(3) + 100*y(2)**3*y(4) + 205*y(2)**2*y(3)**2 + 205*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 + 15*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) + 5*y(3)**2*y(4)**2))/(5*(y(1) & !& - + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 1, & + & 0) = (4*y(2)**2*(50*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 5*y(1)**2*y(3)**2 & + & - 95*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 781*y(2)**4 + 50*y(2)**2*y(3)**2)) & + & /(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 1, & + & 1) = -(4*y(2)**2*(105*y(1)**3*y(2)**2 + 25*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2) & + & *y(4) + 20*y(1)**3*y(3)**2 + 10*y(1)**3*y(3)*y(4) + 110*y(1)**2*y(2)**3 - 35*y(1) & + & **2*y(2)**2*y(3) + 15*y(1)**2*y(2)**2*y(4) + 85*y(1)**2*y(2)*y(3)**2 + 50*y(1) & + & **2*y(2)*y(3)*y(4) + 5*y(1)**2*y(2)*y(4)**2 + 30*y(1)**2*y(3)**3 + 30*y(1) & + & **2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 + 1467*y(1)*y(2)**4 - 460*y(1)*y(2) & + & **3*y(3) - 190*y(1)*y(2)**3*y(4) - 235*y(1)*y(2)**2*y(3)**2 - 260*y(1)*y(2) & + & **2*y(3)*y(4) - 95*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2) & + & *y(3)**2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 3124*y(2)**5 + 3224*y(2)**4*y(3) & + & + 1562*y(2)**4*y(4) + 400*y(2)**3*y(3)**2 + 200*y(2)**3*y(3)*y(4) + 300*y(2) & + & **2*y(3)**3 + 300*y(2)**2*y(3)**2*y(4) + 100*y(2)**2*y(3)*y(4)**2))/(5*(y(2) & + & + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 1, & + & 2) = -(4*y(2)**2*(100*y(1)*y(2)**3 - 190*y(2)**2*y(3)**2 + 10*y(1)*y(3)**3 & + & + 5*y(2)*y(3)**3 - 95*y(2)**3*y(3) - 1562*y(2)**4 + 15*y(1)*y(2)*y(3)**2 & + & + 205*y(1)*y(2)**2*y(3) + 100*y(1)*y(2)**2*y(4) + 10*y(1)*y(3)**2*y(4) + 5*y(2) & + & *y(3)**2*y(4) - 95*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2)) & + & *(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 1, & + & 3) = (4*y(2)**2*(60*y(1)**4*y(2)**2 + 30*y(1)**4*y(2)*y(3) + 15*y(1)**4*y(2)*y(4) & + & + 20*y(1)**4*y(3)**2 + 20*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 135*y(1) & + & **3*y(2)**3 + 140*y(1)**3*y(2)**2*y(3) + 70*y(1)**3*y(2)**2*y(4) + 165*y(1) & + & **3*y(2)*y(3)**2 + 165*y(1)**3*y(2)*y(3)*y(4) + 45*y(1)**3*y(2)*y(4)**2 + 60*y(1) & + & **3*y(3)**3 + 90*y(1)**3*y(3)**2*y(4) + 50*y(1)**3*y(3)*y(4)**2 + 10*y(1)**3*y(4) & + & **3 + 771*y(1)**2*y(2)**4 - 200*y(1)**2*y(2)**3*y(3) - 100*y(1)**2*y(2)**3*y(4) & + & + 25*y(1)**2*y(2)**2*y(3)**2 + 25*y(1)**2*y(2)**2*y(3)*y(4) - 10*y(1)**2*y(2) & + & **2*y(4)**2 + 210*y(1)**2*y(2)*y(3)**3 + 315*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1) & + & **2*y(2)*y(3)*y(4)**2 + 35*y(1)**2*y(2)*y(4)**3 + 45*y(1)**2*y(3)**4 + 90*y(1) & + & **2*y(3)**3*y(4) + 75*y(1)**2*y(3)**2*y(4)**2 + 30*y(1)**2*y(3)*y(4)**3 + 5*y(1) & + & **2*y(4)**4 + 3039*y(1)*y(2)**5 + 2814*y(1)*y(2)**4*y(3) + 1407*y(1)*y(2)**4*y(4) & + & - 120*y(1)*y(2)**3*y(3)**2 - 120*y(1)*y(2)**3*y(3)*y(4) - 50*y(1)*y(2)**3*y(4) & + & **2 + 150*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) + 125*y(1)*y(2) & + & **2*y(3)*y(4)**2 + 25*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2) & + & *y(3)**3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1) & + & *y(2)*y(4)**4 + 3174*y(2)**6 + 6648*y(2)**5*y(3) + 3324*y(2)**5*y(4) + 4224*y(2) & + & **4*y(3)**2 + 4224*y(2)**4*y(3)*y(4) + 1081*y(2)**4*y(4)**2 + 1200*y(2)**3*y(3) & + & **3 + 1800*y(2)**3*y(3)**2*y(4) + 1000*y(2)**3*y(3)*y(4)**2 + 200*y(2)**3*y(4) & + & **3 + 450*y(2)**2*y(3)**4 + 900*y(2)**2*y(3)**3*y(4) + 750*y(2)**2*y(3)**2*y(4) & + & **2 + 300*y(2)**2*y(3)*y(4)**3 + 50*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) & + & + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 1, & + & 4) = (4*y(2)**2*(105*y(1)**2*y(2)**3 + 220*y(1)**2*y(2)**2*y(3) + 110*y(1) & + & **2*y(2)**2*y(4) + 35*y(1)**2*y(2)*y(3)**2 + 35*y(1)**2*y(2)*y(3)*y(4) + 5*y(1) & + & **2*y(2)*y(4)**2 + 20*y(1)**2*y(3)**3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3) & + & *y(4)**2 - 1452*y(1)*y(2)**4 + 250*y(1)*y(2)**3*y(3) + 125*y(1)*y(2)**3*y(4) & + & + 100*y(1)*y(2)**2*y(3)**2 + 100*y(1)*y(2)**2*y(3)*y(4) + 20*y(1)*y(2)**2*y(4) & + & **2 + 90*y(1)*y(2)*y(3)**3 + 135*y(1)*y(2)*y(3)**2*y(4) + 55*y(1)*y(2)*y(3)*y(4) & + & **2 + 5*y(1)*y(2)*y(4)**3 + 30*y(1)*y(3)**4 + 60*y(1)*y(3)**3*y(4) + 40*y(1)*y(3) & + & **2*y(4)**2 + 10*y(1)*y(3)*y(4)**3 - 3219*y(2)**5 - 3694*y(2)**4*y(3) - 1847*y(2) & + & **4*y(4) - 1040*y(2)**3*y(3)**2 - 1040*y(2)**3*y(3)*y(4) - 285*y(2)**3*y(4)**2 & + & - 550*y(2)**2*y(3)**3 - 825*y(2)**2*y(3)**2*y(4) - 465*y(2)**2*y(3)*y(4)**2 & + & - 95*y(2)**2*y(4)**3 + 15*y(2)*y(3)**4 + 30*y(2)*y(3)**3*y(4) + 20*y(2)*y(3) & + & **2*y(4)**2 + 5*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) & + & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 1, & + & 5) = (4*y(2)**2*(831*y(2)**4 + 200*y(2)**3*y(3) + 100*y(2)**3*y(4) + 205*y(2) & + & **2*y(3)**2 + 205*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 & + & + 15*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) & + & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& y = s_cb(i + 1:i + 4) - s_cb(i:i + 3) - beta_coef_${XYZ}$ (i + 1, 0, 0) = (4*y(1)**2*(831*y(1)**4 + 200*y(1)**3*y(2) + 100*y(1)**3*y(3) + 205*y(1)**2*y(2)**2 + 205*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 + 15*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 5*y(2)**4 + 10*y(2)**3*y(3) + 5*y(2)**2*y(3)**2))/(5*(y(3) & !& - + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 0, 1) = -(4*y(1)**2*(1662*y(1)**5 + 3824*y(1)**4*y(2) + 3624*y(1)**4*y(3) + 1762*y(1)**4*y(4) + 1515*y(1)**3*y(2)**2 + 2115*y(1)**3*y(2)*y(3) + 805*y(1)**3*y(2)*y(4) + 700*y(1)**3*y(3)**2 + 500*y(1)**3*y(3)*y(4) + 100*y(1)**3*y(4)**2 + 1060*y(1)**2*y(2)**3 & !& - + 2205*y(1)**2*y(2)**2*y(3) + 835*y(1)**2*y(2)**2*y(4) + 1445*y(1)**2*y(2)*y(3)**2 + 1030*y(1)**2*y(2)*y(3)*y(4) + 205*y(1)**2*y(2)*y(4)**2 + 300*y(1)**2*y(3)**3 + 300*y(1)**2*y(3)**2*y(4) + 100*y(1)**2*y(3)*y(4)**2 + 75*y(1)*y(2)**4 + 180*y(1)*y(2)**3*y(3) & !& - + 60*y(1)*y(2)**3*y(4) + 135*y(1)*y(2)**2*y(3)**2 + 90*y(1)*y(2)**2*y(3)*y(4) + 15*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2)*y(3)**2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 30*y(2)**5 + 90*y(2)**4*y(3) + 30*y(2)**4*y(4) + 90*y(2)**3*y(3)**2 & !& - + 60*y(2)**3*y(3)*y(4) + 10*y(2)**3*y(4)**2 + 30*y(2)**2*y(3)**3 + 30*y(2)**2*y(3)**2*y(4) + 10*y(2)**2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 0, 2) = (4*y(1)**2*(1767*y(1)**4 + 725*y(1)**3*y(2) + 415*y(1)**3*y(3) + 105*y(4)*y(1)**3 + 665*y(1)**2*y(2)**2 + 775*y(1)**2*y(2)*y(3) + 220*y(4)*y(1)**2*y(2) + 215*y(1)**2*y(3)**2 + 110*y(4)*y(1)**2*y(3) + 75*y(1)*y(2)**3 + 130*y(1)*y(2)**2*y(3) + 35*y(4)*y(1)*y(2)**2 & !& - + 60*y(1)*y(2)*y(3)**2 + 35*y(4)*y(1)*y(2)*y(3) + 5*y(1)*y(3)**3 + 5*y(4)*y(1)*y(3)**2 + 30*y(2)**4 + 70*y(2)**3*y(3) + 20*y(4)*y(2)**3 + 50*y(2)**2*y(3)**2 + 30*y(4)*y(2)**2*y(3) + 10*y(2)*y(3)**3 + 10*y(4)*y(2)*y(3)**2)) & !& - /(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 0, 3) = (4*y(1)**2*(831*y(1)**6 + 3624*y(1)**5*y(2) + 3524*y(1)**5*y(3) + 1762*y(1)**5*y(4) + 4884*y(1)**4*y(2)**2 + 9058*y(1)**4*y(2)*y(3) + 4529*y(1)**4*y(2)*y(4) + 4224*y(1)**4*y(3)**2 + 4224*y(1)**4*y(3)*y(4) + 1081*y(1)**4*y(4)**2 + 2565*y(1)**3*y(2)**3 & !& - + 6120*y(1)**3*y(2)**2*y(3) + 3060*y(1)**3*y(2)**2*y(4) + 4755*y(1)**3*y(2)*y(3)**2 + 4755*y(1)**3*y(2)*y(3)*y(4) + 1315*y(1)**3*y(2)*y(4)**2 + 1200*y(1)**3*y(3)**3 + 1800*y(1)**3*y(3)**2*y(4) + 1000*y(1)**3*y(3)*y(4)**2 + 200*y(1)**3*y(4)**3 + 1395*y(1)**2*y(2)**4 & !& - + 4380*y(1)**2*y(2)**3*y(3) + 2190*y(1)**2*y(2)**3*y(4) + 5025*y(1)**2*y(2)**2*y(3)**2 + 5025*y(1)**2*y(2)**2*y(3)*y(4) + 1390*y(1)**2*y(2)**2*y(4)**2 + 2490*y(1)**2*y(2)*y(3)**3 + 3735*y(1)**2*y(2)*y(3)**2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 & !& - + 415*y(1)**2*y(2)*y(4)**3 + 450*y(1)**2*y(3)**4 + 900*y(1)**2*y(3)**3*y(4) + 750*y(1)**2*y(3)**2*y(4)**2 + 300*y(1)**2*y(3)*y(4)**3 + 50*y(1)**2*y(4)**4 + 135*y(1)*y(2)**5 + 450*y(1)*y(2)**4*y(3) + 225*y(1)*y(2)**4*y(4) + 540*y(1)*y(2)**3*y(3)**2 & !& - + 540*y(1)*y(2)**3*y(3)*y(4) + 150*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1)*y(2)**2*y(3)**2*y(4) + 225*y(1)*y(2)**2*y(3)*y(4)**2 + 45*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2)*y(3)**3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 & !& - + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1)*y(2)*y(4)**4 + 45*y(2)**6 + 180*y(2)**5*y(3) + 90*y(2)**5*y(4) + 270*y(2)**4*y(3)**2 + 270*y(2)**4*y(3)*y(4) + 75*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3)**2*y(4) + 150*y(2)**3*y(3)*y(4)**2 + 30*y(2)**3*y(4)**3 & !& - + 45*y(2)**2*y(3)**4 + 90*y(2)**2*y(3)**3*y(4) + 75*y(2)**2*y(3)**2*y(4)**2 + 30*y(2)**2*y(3)*y(4)**3 + 5*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 0, 4) = -(4*y(1)**2*(1767*y(1)**5 + 4464*y(1)**4*y(2) + 4154*y(1)**4*y(3) + 2077*y(1)**4*y(4) + 2655*y(1)**3*y(2)**2 + 4010*y(1)**3*y(2)*y(3) + 2005*y(1)**3*y(2)*y(4) + 1460*y(1)**3*y(3)**2 + 1460*y(1)**3*y(3)*y(4) + 415*y(1)**3*y(4)**2 + 1800*y(1)**2*y(2)**3 & !& - + 4000*y(1)**2*y(2)**2*y(3) + 2000*y(1)**2*y(2)**2*y(4) + 2850*y(1)**2*y(2)*y(3)**2 + 2850*y(1)**2*y(2)*y(3)*y(4) + 790*y(1)**2*y(2)*y(4)**2 + 650*y(1)**2*y(3)**3 + 975*y(1)**2*y(3)**2*y(4) + 535*y(1)**2*y(3)*y(4)**2 + 105*y(1)**2*y(4)**3 + 270*y(1)*y(2)**4 & !& - + 720*y(1)*y(2)**3*y(3) + 360*y(1)*y(2)**3*y(4) + 645*y(1)*y(2)**2*y(3)**2 + 645*y(1)*y(2)**2*y(3)*y(4) + 165*y(1)*y(2)**2*y(4)**2 + 210*y(1)*y(2)*y(3)**3 + 315*y(1)*y(2)*y(3)**2*y(4) + 155*y(1)*y(2)*y(3)*y(4)**2 + 25*y(1)*y(2)*y(4)**3 + 15*y(1)*y(3)**4 & !& - + 30*y(1)*y(3)**3*y(4) + 20*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4)**3 + 90*y(2)**5 + 300*y(2)**4*y(3) + 150*y(2)**4*y(4) + 360*y(2)**3*y(3)**2 + 360*y(2)**3*y(3)*y(4) + 90*y(2)**3*y(4)**2 + 180*y(2)**2*y(3)**3 + 270*y(2)**2*y(3)**2*y(4) + 130*y(2)**2*y(3)*y(4)**2 & !& - + 20*y(2)**2*y(4)**3 + 30*y(2)*y(3)**4 + 60*y(2)*y(3)**3*y(4) + 40*y(2)*y(3)**2*y(4)**2 + 10*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& - beta_coef_${XYZ}$ (i + 1, 0, 5) = (4*y(1)**2*(996*y(1)**4 + 675*y(1)**3*y(2) + 450*y(1)**3*y(3) + 225*y(1)**3*y(4) + 600*y(1)**2*y(2)**2 + 800*y(1)**2*y(2)*y(3) + 400*y(1)**2*y(2)*y(4) + 260*y(1)**2*y(3)**2 + 260*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 135*y(1)*y(2)**3 + 270*y(1)*y(2)**2*y(3) & !& - + 135*y(1)*y(2)**2*y(4) + 165*y(1)*y(2)*y(3)**2 + 165*y(1)*y(2)*y(3)*y(4) + 30*y(1)*y(2)*y(4)**2 + 30*y(1)*y(3)**3 + 45*y(1)*y(3)**2*y(4) + 15*y(1)*y(3)*y(4)**2 + 45*y(2)**4 + 120*y(2)**3*y(3) + 60*y(2)**3*y(4) + 110*y(2)**2*y(3)**2 + 110*y(2)**2*y(3)*y(4) & !& - + 20*y(2)**2*y(4)**2 + 40*y(2)*y(3)**3 + 60*y(2)*y(3)**2*y(4) + 20*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& - + beta_coef_${XYZ}$ (i + 1, 0, & + & 0) = (4*y(1)**2*(831*y(1)**4 + 200*y(1)**3*y(2) + 100*y(1)**3*y(3) + 205*y(1) & + & **2*y(2)**2 + 205*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 & + & + 15*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 5*y(2)**4 + 10*y(2)**3*y(3) & + & + 5*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 0, & + & 1) = -(4*y(1)**2*(1662*y(1)**5 + 3824*y(1)**4*y(2) + 3624*y(1)**4*y(3) & + & + 1762*y(1)**4*y(4) + 1515*y(1)**3*y(2)**2 + 2115*y(1)**3*y(2)*y(3) + 805*y(1) & + & **3*y(2)*y(4) + 700*y(1)**3*y(3)**2 + 500*y(1)**3*y(3)*y(4) + 100*y(1)**3*y(4) & + & **2 + 1060*y(1)**2*y(2)**3 + 2205*y(1)**2*y(2)**2*y(3) + 835*y(1)**2*y(2)**2*y(4) & + & + 1445*y(1)**2*y(2)*y(3)**2 + 1030*y(1)**2*y(2)*y(3)*y(4) + 205*y(1)**2*y(2)*y(4) & + & **2 + 300*y(1)**2*y(3)**3 + 300*y(1)**2*y(3)**2*y(4) + 100*y(1)**2*y(3)*y(4)**2 & + & + 75*y(1)*y(2)**4 + 180*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) + 135*y(1)*y(2) & + & **2*y(3)**2 + 90*y(1)*y(2)**2*y(3)*y(4) + 15*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2) & + & *y(3)**3 + 30*y(1)*y(2)*y(3)**2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 30*y(2)**5 & + & + 90*y(2)**4*y(3) + 30*y(2)**4*y(4) + 90*y(2)**3*y(3)**2 + 60*y(2)**3*y(3)*y(4) & + & + 10*y(2)**3*y(4)**2 + 30*y(2)**2*y(3)**3 + 30*y(2)**2*y(3)**2*y(4) + 10*y(2) & + & **2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & + & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 0, & + & 2) = (4*y(1)**2*(1767*y(1)**4 + 725*y(1)**3*y(2) + 415*y(1)**3*y(3) + 105*y(4) & + & *y(1)**3 + 665*y(1)**2*y(2)**2 + 775*y(1)**2*y(2)*y(3) + 220*y(4)*y(1)**2*y(2) & + & + 215*y(1)**2*y(3)**2 + 110*y(4)*y(1)**2*y(3) + 75*y(1)*y(2)**3 + 130*y(1)*y(2) & + & **2*y(3) + 35*y(4)*y(1)*y(2)**2 + 60*y(1)*y(2)*y(3)**2 + 35*y(4)*y(1)*y(2)*y(3) & + & + 5*y(1)*y(3)**3 + 5*y(4)*y(1)*y(3)**2 + 30*y(2)**4 + 70*y(2)**3*y(3) + 20*y(4) & + & *y(2)**3 + 50*y(2)**2*y(3)**2 + 30*y(4)*y(2)**2*y(3) + 10*y(2)*y(3)**3 + 10*y(4) & + & *y(2)*y(3)**2))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 0, & + & 3) = (4*y(1)**2*(831*y(1)**6 + 3624*y(1)**5*y(2) + 3524*y(1)**5*y(3) + 1762*y(1) & + & **5*y(4) + 4884*y(1)**4*y(2)**2 + 9058*y(1)**4*y(2)*y(3) + 4529*y(1)**4*y(2)*y(4) & + & + 4224*y(1)**4*y(3)**2 + 4224*y(1)**4*y(3)*y(4) + 1081*y(1)**4*y(4)**2 & + & + 2565*y(1)**3*y(2)**3 + 6120*y(1)**3*y(2)**2*y(3) + 3060*y(1)**3*y(2)**2*y(4) & + & + 4755*y(1)**3*y(2)*y(3)**2 + 4755*y(1)**3*y(2)*y(3)*y(4) + 1315*y(1)**3*y(2) & + & *y(4)**2 + 1200*y(1)**3*y(3)**3 + 1800*y(1)**3*y(3)**2*y(4) + 1000*y(1)**3*y(3) & + & *y(4)**2 + 200*y(1)**3*y(4)**3 + 1395*y(1)**2*y(2)**4 + 4380*y(1)**2*y(2)**3*y(3) & + & + 2190*y(1)**2*y(2)**3*y(4) + 5025*y(1)**2*y(2)**2*y(3)**2 + 5025*y(1)**2*y(2) & + & **2*y(3)*y(4) + 1390*y(1)**2*y(2)**2*y(4)**2 + 2490*y(1)**2*y(2)*y(3)**3 & + & + 3735*y(1)**2*y(2)*y(3)**2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 415*y(1) & + & **2*y(2)*y(4)**3 + 450*y(1)**2*y(3)**4 + 900*y(1)**2*y(3)**3*y(4) + 750*y(1) & + & **2*y(3)**2*y(4)**2 + 300*y(1)**2*y(3)*y(4)**3 + 50*y(1)**2*y(4)**4 + 135*y(1) & + & *y(2)**5 + 450*y(1)*y(2)**4*y(3) + 225*y(1)*y(2)**4*y(4) + 540*y(1)*y(2)**3*y(3) & + & **2 + 540*y(1)*y(2)**3*y(3)*y(4) + 150*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2) & + & **2*y(3)**3 + 405*y(1)*y(2)**2*y(3)**2*y(4) + 225*y(1)*y(2)**2*y(3)*y(4)**2 & + & + 45*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2)*y(3)**3*y(4) & + & + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1)*y(2)*y(4)**4 & + & + 45*y(2)**6 + 180*y(2)**5*y(3) + 90*y(2)**5*y(4) + 270*y(2)**4*y(3)**2 & + & + 270*y(2)**4*y(3)*y(4) + 75*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2) & + & **3*y(3)**2*y(4) + 150*y(2)**3*y(3)*y(4)**2 + 30*y(2)**3*y(4)**3 + 45*y(2) & + & **2*y(3)**4 + 90*y(2)**2*y(3)**3*y(4) + 75*y(2)**2*y(3)**2*y(4)**2 + 30*y(2) & + & **2*y(3)*y(4)**3 + 5*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3)) & + & **2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 0, & + & 4) = -(4*y(1)**2*(1767*y(1)**5 + 4464*y(1)**4*y(2) + 4154*y(1)**4*y(3) & + & + 2077*y(1)**4*y(4) + 2655*y(1)**3*y(2)**2 + 4010*y(1)**3*y(2)*y(3) + 2005*y(1) & + & **3*y(2)*y(4) + 1460*y(1)**3*y(3)**2 + 1460*y(1)**3*y(3)*y(4) + 415*y(1)**3*y(4) & + & **2 + 1800*y(1)**2*y(2)**3 + 4000*y(1)**2*y(2)**2*y(3) + 2000*y(1)**2*y(2) & + & **2*y(4) + 2850*y(1)**2*y(2)*y(3)**2 + 2850*y(1)**2*y(2)*y(3)*y(4) + 790*y(1) & + & **2*y(2)*y(4)**2 + 650*y(1)**2*y(3)**3 + 975*y(1)**2*y(3)**2*y(4) + 535*y(1) & + & **2*y(3)*y(4)**2 + 105*y(1)**2*y(4)**3 + 270*y(1)*y(2)**4 + 720*y(1)*y(2)**3*y(3) & + & + 360*y(1)*y(2)**3*y(4) + 645*y(1)*y(2)**2*y(3)**2 + 645*y(1)*y(2)**2*y(3)*y(4) & + & + 165*y(1)*y(2)**2*y(4)**2 + 210*y(1)*y(2)*y(3)**3 + 315*y(1)*y(2)*y(3)**2*y(4) & + & + 155*y(1)*y(2)*y(3)*y(4)**2 + 25*y(1)*y(2)*y(4)**3 + 15*y(1)*y(3)**4 + 30*y(1) & + & *y(3)**3*y(4) + 20*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4)**3 + 90*y(2)**5 & + & + 300*y(2)**4*y(3) + 150*y(2)**4*y(4) + 360*y(2)**3*y(3)**2 + 360*y(2)**3*y(3) & + & *y(4) + 90*y(2)**3*y(4)**2 + 180*y(2)**2*y(3)**3 + 270*y(2)**2*y(3)**2*y(4) & + & + 130*y(2)**2*y(3)*y(4)**2 + 20*y(2)**2*y(4)**3 + 30*y(2)*y(3)**4 + 60*y(2)*y(3) & + & **3*y(4) + 40*y(2)*y(3)**2*y(4)**2 + 10*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2)) & + & *(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))**2) !& + beta_coef_${XYZ}$ (i + 1, 0, & + & 5) = (4*y(1)**2*(996*y(1)**4 + 675*y(1)**3*y(2) + 450*y(1)**3*y(3) + 225*y(1) & + & **3*y(4) + 600*y(1)**2*y(2)**2 + 800*y(1)**2*y(2)*y(3) + 400*y(1)**2*y(2)*y(4) & + & + 260*y(1)**2*y(3)**2 + 260*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 135*y(1) & + & *y(2)**3 + 270*y(1)*y(2)**2*y(3) + 135*y(1)*y(2)**2*y(4) + 165*y(1)*y(2)*y(3)**2 & + & + 165*y(1)*y(2)*y(3)*y(4) + 30*y(1)*y(2)*y(4)**2 + 30*y(1)*y(3)**3 + 45*y(1)*y(3) & + & **2*y(4) + 15*y(1)*y(3)*y(4)**2 + 45*y(2)**4 + 120*y(2)**3*y(3) + 60*y(2)**3*y(4) & + & + 110*y(2)**2*y(3)**2 + 110*y(2)**2*y(3)*y(4) + 20*y(2)**2*y(4)**2 + 40*y(2)*y(3) & + & **3 + 60*y(2)*y(3)**2*y(4) + 20*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) & + & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& end do - else ! TENO (only supports uniform grid) ! (Fu, et al., 2016) Table 2 (for right flux) - d_cbL_${XYZ}$ (0, :) = 18._wp/35._wp - d_cbL_${XYZ}$ (1, :) = 3._wp/35._wp - d_cbL_${XYZ}$ (2, :) = 9._wp/35._wp - d_cbL_${XYZ}$ (3, :) = 1._wp/35._wp - d_cbL_${XYZ}$ (4, :) = 4._wp/35._wp - - d_cbR_${XYZ}$ (0, :) = 18._wp/35._wp - d_cbR_${XYZ}$ (1, :) = 9._wp/35._wp - d_cbR_${XYZ}$ (2, :) = 3._wp/35._wp - d_cbR_${XYZ}$ (3, :) = 4._wp/35._wp - d_cbR_${XYZ}$ (4, :) = 1._wp/35._wp - + d_cbL_${XYZ}$ (0,:) = 18._wp/35._wp + d_cbL_${XYZ}$ (1,:) = 3._wp/35._wp + d_cbL_${XYZ}$ (2,:) = 9._wp/35._wp + d_cbL_${XYZ}$ (3,:) = 1._wp/35._wp + d_cbL_${XYZ}$ (4,:) = 4._wp/35._wp + + d_cbR_${XYZ}$ (0,:) = 18._wp/35._wp + d_cbR_${XYZ}$ (1,:) = 9._wp/35._wp + d_cbR_${XYZ}$ (2,:) = 3._wp/35._wp + d_cbR_${XYZ}$ (3,:) = 4._wp/35._wp + d_cbR_${XYZ}$ (4,:) = 1._wp/35._wp end if end if - end if #:endfor if (weno_dir == 1) then - $:GPU_UPDATE(device='[poly_coef_cbL_x,poly_coef_cbR_x,d_cbL_x,d_cbR_x,beta_coef_x]') - elseif (weno_dir == 2) then - $:GPU_UPDATE(device='[poly_coef_cbL_y,poly_coef_cbR_y,d_cbL_y,d_cbR_y,beta_coef_y]') + $:GPU_UPDATE(device='[poly_coef_cbL_x, poly_coef_cbR_x, d_cbL_x, d_cbR_x, beta_coef_x]') + else if (weno_dir == 2) then + $:GPU_UPDATE(device='[poly_coef_cbL_y, poly_coef_cbR_y, d_cbL_y, d_cbR_y, beta_coef_y]') else - $:GPU_UPDATE(device='[poly_coef_cbL_z,poly_coef_cbR_z,d_cbL_z,d_cbR_z,beta_coef_z]') + $:GPU_UPDATE(device='[poly_coef_cbL_z, poly_coef_cbR_z, d_cbL_z, d_cbR_z, beta_coef_z]') end if ! Nullifying WENO coefficients and cell-boundary locations pointers nullify (s_cb) - end subroutine s_compute_weno_coefficients - !> @brief Performs WENO reconstruction of left and right cell-boundary values from cell-averaged variables. - subroutine s_weno(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, & - weno_dir, & - is1_weno_d, is2_weno_d, is3_weno_d) - - type(scalar_field), dimension(1:), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z - integer, intent(in) :: weno_dir + subroutine s_weno(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, weno_dir, is1_weno_d, & + & is2_weno_d, is3_weno_d) + + type(scalar_field), dimension(1:), intent(in) :: v_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & + & vL_rs_vf_z + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_rs_vf_x, vR_rs_vf_y, & + & vR_rs_vf_z + integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is1_weno_d, is2_weno_d, is3_weno_d #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(-3:2) :: dvd - real(wp), dimension(0:4) :: poly - real(wp), dimension(0:4) :: alpha - real(wp), dimension(0:4) :: omega - real(wp), dimension(0:4) :: beta - real(wp), dimension(0:4) :: delta + real(wp), dimension(0:4) :: poly + real(wp), dimension(0:4) :: alpha + real(wp), dimension(0:4) :: omega + real(wp), dimension(0:4) :: beta + real(wp), dimension(0:4) :: delta #:else real(wp), dimension(-weno_polyn:weno_polyn - 1) :: dvd - real(wp), dimension(0:weno_num_stencils) :: poly - real(wp), dimension(0:weno_num_stencils) :: alpha - real(wp), dimension(0:weno_num_stencils) :: omega - real(wp), dimension(0:weno_num_stencils) :: beta - real(wp), dimension(0:weno_num_stencils) :: delta + real(wp), dimension(0:weno_num_stencils) :: poly + real(wp), dimension(0:weno_num_stencils) :: alpha + real(wp), dimension(0:weno_num_stencils) :: omega + real(wp), dimension(0:weno_num_stencils) :: beta + real(wp), dimension(0:weno_num_stencils) :: delta #:endif real(wp), dimension(-3:3) :: v ! temporary field value array for clarity (WENO7 only) - real(wp) :: tau - - integer :: i, j, k, l, q + real(wp) :: tau + integer :: i, j, k, l, q is1_weno = is1_weno_d is2_weno = is2_weno_d is3_weno = is3_weno_d - $:GPU_UPDATE(device='[is1_weno,is2_weno,is3_weno]') + $:GPU_UPDATE(device='[is1_weno, is2_weno, is3_weno]') if (weno_order /= 1 .or. dummy) then - call s_initialize_weno(v_vf, & - weno_dir) + call s_initialize_weno(v_vf, weno_dir) end if if (weno_order == 1 .or. dummy) then @@ -712,7 +946,7 @@ contains if (weno_order == 3 .or. dummy) then #:for WENO_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (weno_dir == ${WENO_DIR}$) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[beta,dvd,poly,omega,alpha,tau]') + $:GPU_PARALLEL_LOOP(collapse=4,private='[beta, dvd, poly, omega, alpha, tau]') do l = is3_weno%beg, is3_weno%end do k = is2_weno%beg, is2_weno%end do j = is1_weno%beg, is1_weno%end @@ -723,36 +957,34 @@ contains omega(:) = 0._wp beta(:) = weno_eps - dvd(0) = v_rs_ws_${XYZ}$ (j + 1, k, l, i) & - - v_rs_ws_${XYZ}$ (j, k, l, i) - dvd(-1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - - v_rs_ws_${XYZ}$ (j - 1, k, l, i) + dvd(0) = v_rs_ws_${XYZ}$ (j + 1, k, l, i) - v_rs_ws_${XYZ}$ (j, k, l, i) + dvd(-1) = v_rs_ws_${XYZ}$ (j, k, l, i) - v_rs_ws_${XYZ}$ (j - 1, k, l, i) - poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 1, 0)*dvd(-1) + poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 0, 0)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 1, 0)*dvd(-1) - beta(0) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(-1)*dvd(-1) & - + weno_eps + beta(0) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(0)*dvd(0) + weno_eps + beta(1) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(-1)*dvd(-1) + weno_eps if (wenojs) then - alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) - - elseif (mapped_weno) then - alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) + alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) + else if (mapped_weno) then + alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) - alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, j)**2._wp + omega(0:weno_num_stencils)*(1._wp - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) - - elseif (wenoz) then + alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + else if (wenoz) then ! Borges, et al. (2008) tau = abs(beta(1) - beta(0)) - alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, j)*(1._wp + tau/beta(0:weno_num_stencils)) - + alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)*(1._wp + tau/beta(0:weno_num_stencils)) end if omega = alpha/sum(alpha) @@ -761,30 +993,30 @@ contains ! reconstruct from right side - poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 0, 0)*dvd(0) - poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 1, 0)*dvd(-1) + poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 0, 0)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 1, 0)*dvd(-1) if (wenojs) then - alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) - - elseif (mapped_weno) then - alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) + alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) + else if (mapped_weno) then + alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) - alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, j)**2._wp + omega(0:weno_num_stencils)*(1._wp - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) - - elseif (wenoz) then - - alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, j)*(1._wp + tau/beta(0:weno_num_stencils)) - + alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + else if (wenoz) then + alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)*(1._wp + tau/beta(0:weno_num_stencils)) end if omega = alpha/sum(alpha) vR_rs_vf_${XYZ}$ (j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) - end do end do end do @@ -797,7 +1029,7 @@ contains #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 1 #:for WENO_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (weno_dir == ${WENO_DIR}$) then - $:GPU_PARALLEL_LOOP(collapse=3,private='[dvd,poly,beta,alpha,omega,tau,delta,q]') + $:GPU_PARALLEL_LOOP(collapse=3,private='[dvd, poly, beta, alpha, omega, tau, delta, q]') do l = is3_weno%beg, is3_weno%end do k = is2_weno%beg, is2_weno%end do j = is1_weno%beg, is1_weno%end @@ -810,71 +1042,63 @@ contains delta(:) = 0._wp beta(:) = weno_eps - dvd(1) = v_rs_ws_${XYZ}$ (j + 2, k, l, i) & - - v_rs_ws_${XYZ}$ (j + 1, k, l, i) - dvd(0) = v_rs_ws_${XYZ}$ (j + 1, k, l, i) & - - v_rs_ws_${XYZ}$ (j, k, l, i) - dvd(-1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - - v_rs_ws_${XYZ}$ (j - 1, k, l, i) - dvd(-2) = v_rs_ws_${XYZ}$ (j - 1, k, l, i) & - - v_rs_ws_${XYZ}$ (j - 2, k, l, i) - - poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 0, 0)*dvd(1) & - + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 1, 0)*dvd(0) & - + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 2, 0)*dvd(-1) & - + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-2) - - beta(0) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(1)*dvd(1) & - + beta_coef_${XYZ}$ (j, 0, 1)*dvd(1)*dvd(0) & - + beta_coef_${XYZ}$ (j, 0, 2)*dvd(0)*dvd(0) & - + weno_eps - beta(1) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(0)*dvd(0) & - + beta_coef_${XYZ}$ (j, 1, 1)*dvd(0)*dvd(-1) & - + beta_coef_${XYZ}$ (j, 1, 2)*dvd(-1)*dvd(-1) & - + weno_eps - beta(2) = beta_coef_${XYZ}$ (j, 2, 0)*dvd(-1)*dvd(-1) & - + beta_coef_${XYZ}$ (j, 2, 1)*dvd(-1)*dvd(-2) & - + beta_coef_${XYZ}$ (j, 2, 2)*dvd(-2)*dvd(-2) & - + weno_eps + dvd(1) = v_rs_ws_${XYZ}$ (j + 2, k, l, i) - v_rs_ws_${XYZ}$ (j + 1, k, l, i) + dvd(0) = v_rs_ws_${XYZ}$ (j + 1, k, l, i) - v_rs_ws_${XYZ}$ (j, k, l, i) + dvd(-1) = v_rs_ws_${XYZ}$ (j, k, l, i) - v_rs_ws_${XYZ}$ (j - 1, k, l, i) + dvd(-2) = v_rs_ws_${XYZ}$ (j - 1, k, l, i) - v_rs_ws_${XYZ}$ (j - 2, k, l, i) + + poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 0, & + & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 1, & + & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(-1) + poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 2, & + & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-2) + + beta(0) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & + & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 2)*dvd(0)*dvd(0) + weno_eps + beta(1) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & + & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 2)*dvd(-1)*dvd(-1) + weno_eps + beta(2) = beta_coef_${XYZ}$ (j, 2, 0)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & + & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 2)*dvd(-2)*dvd(-2) + weno_eps if (wenojs) then - alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) - - elseif (mapped_weno) then - alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) + alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) + else if (mapped_weno) then + alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) - alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, j)**2._wp + omega(0:weno_num_stencils)*(1._wp - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) - - elseif (wenoz) then - + alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + else if (wenoz) then ! Borges, et al. (2008) - tau = abs(beta(2) - beta(0)) ! Equation 25 + tau = abs(beta(2) - beta(0)) ! Equation 25 $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - alpha(q) = d_cbL_${XYZ}$ (q, j)*(1._wp + (tau/beta(q))) ! Equation 28 (note: weno_eps was already added to beta) + alpha(q) = d_cbL_${XYZ}$ (q, & + & j)*(1._wp + (tau/beta(q))) & + & ! Equation 28 (note: weno_eps was already added to beta) end do - - elseif (teno) then + else if (teno) then ! Fu, et al. (2016) ! Fu''s code: https://dx.doi.org/10.13140/RG.2.2.36250.34247 tau = abs(beta(2) - beta(0)) $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - alpha(q) = 1._wp + tau/beta(q) ! Equation 22 (reuse alpha as gamma; pick C=1 & q=6) - alpha(q) = (alpha(q)**3._wp)**2._wp ! Equation 22 cont. (some CPU compilers cannot optimize x**6.0) + alpha(q) = 1._wp + tau/beta(q) ! Equation 22 (reuse alpha as gamma; pick C=1 & q=6) + alpha(q) = (alpha(q)**3._wp) & + & **2._wp ! Equation 22 cont. (some CPU compilers cannot optimize x**6.0) end do - omega = alpha/sum(alpha) ! Equation 25 (reuse omega as xi) + omega = alpha/sum(alpha) ! Equation 25 (reuse omega as xi) $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - if (omega(q) < teno_CT) then ! Equation 26 + if (omega(q) < teno_CT) then ! Equation 26 delta(q) = 0._wp else delta(q) = 1._wp @@ -889,33 +1113,32 @@ contains ! reconstruct from right side - poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 0, 0)*dvd(1) & - + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(0) - poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 1, 0)*dvd(0) & - + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(-1) - poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 2, 0)*dvd(-1) & - + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-2) + poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 0, & + & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(0) + poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 1, & + & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(-1) + poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 2, & + & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-2) if (wenojs) then - alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) - - elseif (mapped_weno) then - alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) + alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) + else if (mapped_weno) then + alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) - alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, j)**2._wp + omega(0:weno_num_stencils)*(1._wp - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) - - elseif (wenoz) then - + alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + else if (wenoz) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbR_${XYZ}$ (q, j)*(1._wp + (tau/beta(q))) end do - - elseif (teno) then + else if (teno) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = delta(q)*d_cbR_${XYZ}$ (q, j) @@ -925,7 +1148,6 @@ contains omega = alpha/sum(alpha) vR_rs_vf_${XYZ}$ (j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) - end do end do end do @@ -933,8 +1155,7 @@ contains $:END_GPU_PARALLEL_LOOP() if (mp_weno) then - call s_preserve_monotonicity(v_rs_ws_${XYZ}$, vL_rs_vf_${XYZ}$, & - vR_rs_vf_${XYZ}$) + call s_preserve_monotonicity(v_rs_ws_${XYZ}$, vL_rs_vf_${XYZ}$, vR_rs_vf_${XYZ}$) end if end if #:endfor @@ -944,112 +1165,94 @@ contains #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 2 #:for WENO_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (weno_dir == ${WENO_DIR}$) then - $:GPU_PARALLEL_LOOP(collapse=3,private='[poly,beta,alpha,omega,tau,delta,dvd,v,q]') + $:GPU_PARALLEL_LOOP(collapse=3,private='[poly, beta, alpha, omega, tau, delta, dvd, v, q]') do l = is3_weno%beg, is3_weno%end do k = is2_weno%beg, is2_weno%end do j = is1_weno%beg, is1_weno%end $:GPU_LOOP(parallelism='[seq]') do i = 1, v_size - alpha(:) = 0._wp omega(:) = 0._wp delta(:) = 0._wp beta(:) = weno_eps - if (teno) v = v_rs_ws_${XYZ}$ (j - 3:j + 3, k, l, i) ! temporary field value array for clarity + if (teno) v = v_rs_ws_${XYZ}$ (j - 3:j + 3, k, l, & + & i) ! temporary field value array for clarity if (.not. teno) then - dvd(2) = v_rs_ws_${XYZ}$ (j + 3, k, l, i) & - - v_rs_ws_${XYZ}$ (j + 2, k, l, i) - dvd(1) = v_rs_ws_${XYZ}$ (j + 2, k, l, i) & - - v_rs_ws_${XYZ}$ (j + 1, k, l, i) - dvd(0) = v_rs_ws_${XYZ}$ (j + 1, k, l, i) & - - v_rs_ws_${XYZ}$ (j, k, l, i) - dvd(-1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - - v_rs_ws_${XYZ}$ (j - 1, k, l, i) - dvd(-2) = v_rs_ws_${XYZ}$ (j - 1, k, l, i) & - - v_rs_ws_${XYZ}$ (j - 2, k, l, i) - dvd(-3) = v_rs_ws_${XYZ}$ (j - 2, k, l, i) & - - v_rs_ws_${XYZ}$ (j - 3, k, l, i) - - poly(3) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 0, 0)*dvd(2) & - + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(1) & - + poly_coef_cbL_${XYZ}$ (j, 0, 2)*dvd(0) - poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 1, 0)*dvd(1) & - + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(0) & - + poly_coef_cbL_${XYZ}$ (j, 1, 2)*dvd(-1) - poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 2, 0)*dvd(0) & - + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-1) & - + poly_coef_cbL_${XYZ}$ (j, 2, 2)*dvd(-2) - poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbL_${XYZ}$ (j, 3, 0)*dvd(-1) & - + poly_coef_cbL_${XYZ}$ (j, 3, 1)*dvd(-2) & - + poly_coef_cbL_${XYZ}$ (j, 3, 2)*dvd(-3) - + dvd(2) = v_rs_ws_${XYZ}$ (j + 3, k, l, i) - v_rs_ws_${XYZ}$ (j + 2, k, l, i) + dvd(1) = v_rs_ws_${XYZ}$ (j + 2, k, l, i) - v_rs_ws_${XYZ}$ (j + 1, k, l, i) + dvd(0) = v_rs_ws_${XYZ}$ (j + 1, k, l, i) - v_rs_ws_${XYZ}$ (j, k, l, i) + dvd(-1) = v_rs_ws_${XYZ}$ (j, k, l, i) - v_rs_ws_${XYZ}$ (j - 1, k, l, i) + dvd(-2) = v_rs_ws_${XYZ}$ (j - 1, k, l, i) - v_rs_ws_${XYZ}$ (j - 2, k, l, i) + dvd(-3) = v_rs_ws_${XYZ}$ (j - 2, k, l, i) - v_rs_ws_${XYZ}$ (j - 3, k, l, i) + + poly(3) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 0, & + & 0)*dvd(2) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, & + & 0, 2)*dvd(0) + poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 1, & + & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, & + & 1, 2)*dvd(-1) + poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 2, & + & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 2, & + & 1)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 2, 2)*dvd(-2) + poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 3, & + & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 3, & + & 1)*dvd(-2) + poly_coef_cbL_${XYZ}$ (j, 3, 2)*dvd(-3) else #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 ! (Fu, et al., 2016) Table 1 ! Note: Unlike TENO5, TENO7 stencils differ from WENO7 stencils ! See Figure 2 (right) for right-sided flux (at i+1/2) - ! Here we need the left-sided flux, so we flip the weights with respect to the x=i point + ! Here we need the left-sided flux, so we flip the weights with respect to the x=i + ! point ! But we need to keep the stencil order to reuse the beta coefficients - poly(0) = ( 2._wp*v(-1) + 5._wp*v( 0) - 1._wp*v( 1)) / 6._wp !& - poly(1) = (11._wp*v( 0) - 7._wp*v( 1) + 2._wp*v( 2)) / 6._wp !& - poly(2) = (-1._wp*v(-2) + 5._wp*v(-1) + 2._wp*v( 0)) / 6._wp !& - poly(3) = (25._wp*v( 0) - 23._wp*v( 1) + 13._wp*v( 2) - 3._wp*v( 3)) / 12._wp !& - poly(4) = ( 1._wp*v(-3) - 5._wp*v(-2) + 13._wp*v(-1) + 3._wp*v( 0)) / 12._wp !& + poly(0) = (2._wp*v(-1) + 5._wp*v(0) - 1._wp*v(1))/6._wp !& + poly(1) = (11._wp*v(0) - 7._wp*v(1) + 2._wp*v(2))/6._wp !& + poly(2) = (-1._wp*v(-2) + 5._wp*v(-1) + 2._wp*v(0))/6._wp !& + poly(3) = (25._wp*v(0) - 23._wp*v(1) + 13._wp*v(2) - 3._wp*v(3))/12._wp !& + poly(4) = (1._wp*v(-3) - 5._wp*v(-2) + 13._wp*v(-1) + 3._wp*v(0))/12._wp !& #:endif end if if (.not. teno) then - - beta(3) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(2)*dvd(2) & - + beta_coef_${XYZ}$ (j, 0, 1)*dvd(2)*dvd(1) & - + beta_coef_${XYZ}$ (j, 0, 2)*dvd(2)*dvd(0) & - + beta_coef_${XYZ}$ (j, 0, 3)*dvd(1)*dvd(1) & - + beta_coef_${XYZ}$ (j, 0, 4)*dvd(1)*dvd(0) & - + beta_coef_${XYZ}$ (j, 0, 5)*dvd(0)*dvd(0) & - + weno_eps - - beta(2) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(1)*dvd(1) & - + beta_coef_${XYZ}$ (j, 1, 1)*dvd(1)*dvd(0) & - + beta_coef_${XYZ}$ (j, 1, 2)*dvd(1)*dvd(-1) & - + beta_coef_${XYZ}$ (j, 1, 3)*dvd(0)*dvd(0) & - + beta_coef_${XYZ}$ (j, 1, 4)*dvd(0)*dvd(-1) & - + beta_coef_${XYZ}$ (j, 1, 5)*dvd(-1)*dvd(-1) & - + weno_eps - - beta(1) = beta_coef_${XYZ}$ (j, 2, 0)*dvd(0)*dvd(0) & - + beta_coef_${XYZ}$ (j, 2, 1)*dvd(0)*dvd(-1) & - + beta_coef_${XYZ}$ (j, 2, 2)*dvd(0)*dvd(-2) & - + beta_coef_${XYZ}$ (j, 2, 3)*dvd(-1)*dvd(-1) & - + beta_coef_${XYZ}$ (j, 2, 4)*dvd(-1)*dvd(-2) & - + beta_coef_${XYZ}$ (j, 2, 5)*dvd(-2)*dvd(-2) & - + weno_eps - - beta(0) = beta_coef_${XYZ}$ (j, 3, 0)*dvd(-1)*dvd(-1) & - + beta_coef_${XYZ}$ (j, 3, 1)*dvd(-1)*dvd(-2) & - + beta_coef_${XYZ}$ (j, 3, 2)*dvd(-1)*dvd(-3) & - + beta_coef_${XYZ}$ (j, 3, 3)*dvd(-2)*dvd(-2) & - + beta_coef_${XYZ}$ (j, 3, 4)*dvd(-2)*dvd(-3) & - + beta_coef_${XYZ}$ (j, 3, 5)*dvd(-3)*dvd(-3) & - + weno_eps - + beta(3) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(2)*dvd(2) + beta_coef_${XYZ}$ (j, 0, & + & 1)*dvd(2)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & + & 2)*dvd(2)*dvd(0) + beta_coef_${XYZ}$ (j, 0, & + & 3)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & + & 4)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 5)*dvd(0)*dvd(0) + weno_eps + + beta(2) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 1, & + & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & + & 2)*dvd(1)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, & + & 3)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & + & 4)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 5)*dvd(-1)*dvd(-1) + weno_eps + + beta(1) = beta_coef_${XYZ}$ (j, 2, 0)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 2, & + & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & + & 2)*dvd(0)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, & + & 3)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & + & 4)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 5)*dvd(-2)*dvd(-2) + weno_eps + + beta(0) = beta_coef_${XYZ}$ (j, 3, 0)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 3, & + & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & + & 2)*dvd(-1)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, & + & 3)*dvd(-2)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & + & 4)*dvd(-2)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, 5)*dvd(-3)*dvd(-3) + weno_eps else ! TENO #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 - ! High-Order Low-Dissipation Targeted ENO Schemes for Ideal Magnetohydrodynamics (Fu & Tang, 2019) Section 3.2 - beta(0) = 13._wp/12._wp*(v(-1) - 2._wp*v( 0) + v( 1))**2._wp + (( v(-1) - v( 1))**2._wp)/4._wp + weno_eps !& - beta(1) = 13._wp/12._wp*(v( 0) - 2._wp*v( 1) + v( 2))**2._wp + ((3._wp*v( 0) - 4._wp*v( 1) + v( 2))**2._wp)/4._wp + weno_eps !& - beta(2) = 13._wp/12._wp*(v(-2) - 2._wp*v(-1) + v( 0))**2._wp + (( v(-2) - 4._wp*v(-1) + 3._wp*v( 0))**2._wp)/4._wp + weno_eps !& - - beta(3) = ( v( 0)*(2107._wp*v( 0) - 9402._wp*v( 1) + 7042._wp*v( 2) - 1854._wp*v( 3)) & !& - + v( 1)*( 11003._wp*v( 1) - 17246._wp*v( 2) + 4642._wp*v( 3)) & !& - + v( 2)*( 7043._wp*v( 2) - 3882._wp*v( 3)) & !& - + v( 3)*( 547._wp*v( 3)) ) / 240._wp & !& - + weno_eps !& + ! High-Order Low-Dissipation Targeted ENO Schemes for Ideal Magnetohydrodynamics (Fu + ! & Tang, 2019) Section 3.2 + beta(0) = 13._wp/12._wp*(v(-1) - 2._wp*v(0) + v(1))**2._wp + ((v(-1) - v(1)) & + & **2._wp)/4._wp + weno_eps !& + beta(1) = 13._wp/12._wp*(v(0) - 2._wp*v(1) + v(2))**2._wp + ((3._wp*v(0) & + & - 4._wp*v(1) + v(2))**2._wp)/4._wp + weno_eps !& + beta(2) = 13._wp/12._wp*(v(-2) - 2._wp*v(-1) + v(0))**2._wp + ((v(-2) & + & - 4._wp*v(-1) + 3._wp*v(0))**2._wp)/4._wp + weno_eps !& + + beta(3) = (v(0)*(2107._wp*v(0) - 9402._wp*v(1) + 7042._wp*v(2) - 1854._wp*v(3)) & + & + v(1)*(11003._wp*v(1) - 17246._wp*v(2) + 4642._wp*v(3)) + v(2) & + & *(7043._wp*v(2) - 3882._wp*v(3)) + v(3)*(547._wp*v(3)))/240._wp + weno_eps !& beta(4) = ( v(-3)*(547._wp*v(-3) - 3882._wp*v(-2) + 4642._wp*v(-1) - 1854._wp*v( 0)) & !& + v(-2)*( 7043._wp*v(-2) - 17246._wp*v(-1) + 7042._wp*v( 0)) & !& @@ -1060,24 +1263,28 @@ contains end if if (wenojs) then - alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) - - elseif (mapped_weno) then - alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) + alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) + else if (mapped_weno) then + alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) - alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, j)**2._wp + omega(0:weno_num_stencils)*(1._wp - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) - - elseif (wenoz) then + alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + else if (wenoz) then ! Castro, et al. (2010) ! Don & Borges (2013) also helps tau = abs(beta(3) - beta(0)) ! Equation 50 $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - alpha(q) = d_cbL_${XYZ}$ (q, j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability + alpha(q) = d_cbL_${XYZ}$ (q, & + & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability end do - - elseif (teno) then + else if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 tau = abs(beta(4) - beta(3)) ! Note the reordering of stencils alpha = 1._wp + tau/beta @@ -1086,7 +1293,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - if (omega(q) < teno_CT) then ! Equation 26 + if (omega(q) < teno_CT) then ! Equation 26 delta(q) = 0._wp else delta(q) = 1._wp @@ -1098,7 +1305,9 @@ contains omega = alpha/sum(alpha) - vL_rs_vf_${XYZ}$ (j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3)*poly(3) + vL_rs_vf_${XYZ}$ (j, k, l, & + & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3) & + & *poly(3) if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 @@ -1107,49 +1316,48 @@ contains end if if (.not. teno) then - poly(3) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 0, 0)*dvd(2) & - + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(1) & - + poly_coef_cbR_${XYZ}$ (j, 0, 2)*dvd(0) - poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 1, 0)*dvd(1) & - + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(0) & - + poly_coef_cbR_${XYZ}$ (j, 1, 2)*dvd(-1) - poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 2, 0)*dvd(0) & - + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-1) & - + poly_coef_cbR_${XYZ}$ (j, 2, 2)*dvd(-2) - poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) & - + poly_coef_cbR_${XYZ}$ (j, 3, 0)*dvd(-1) & - + poly_coef_cbR_${XYZ}$ (j, 3, 1)*dvd(-2) & - + poly_coef_cbR_${XYZ}$ (j, 3, 2)*dvd(-3) + poly(3) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 0, & + & 0)*dvd(2) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, & + & 0, 2)*dvd(0) + poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 1, & + & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, & + & 1, 2)*dvd(-1) + poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 2, & + & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 2, & + & 1)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 2, 2)*dvd(-2) + poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 3, & + & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 3, & + & 1)*dvd(-2) + poly_coef_cbR_${XYZ}$ (j, 3, 2)*dvd(-3) else #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 - poly(0) = (-1._wp*v(-1) + 5._wp*v( 0) + 2._wp*v( 1)) / 6._wp !& - poly(1) = ( 2._wp*v( 0) + 5._wp*v( 1) - 1._wp*v( 2)) / 6._wp !& - poly(2) = ( 2._wp*v(-2) - 7._wp*v(-1) + 11._wp*v( 0)) / 6._wp !& - poly(3) = ( 3._wp*v( 0) + 13._wp*v( 1) - 5._wp*v( 2) + 1._wp*v( 3)) / 12._wp !& - poly(4) = (-3._wp*v(-3) + 13._wp*v(-2) - 23._wp*v(-1) + 25._wp*v( 0)) / 12._wp !& + poly(0) = (-1._wp*v(-1) + 5._wp*v(0) + 2._wp*v(1))/6._wp !& + poly(1) = (2._wp*v(0) + 5._wp*v(1) - 1._wp*v(2))/6._wp !& + poly(2) = (2._wp*v(-2) - 7._wp*v(-1) + 11._wp*v(0))/6._wp !& + poly(3) = (3._wp*v(0) + 13._wp*v(1) - 5._wp*v(2) + 1._wp*v(3))/12._wp !& + poly(4) = (-3._wp*v(-3) + 13._wp*v(-2) - 23._wp*v(-1) + 25._wp*v(0))/12._wp !& #:endif end if if (wenojs) then - alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) - - elseif (mapped_weno) then - alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, j)/(beta(0:weno_num_stencils)**2._wp) + alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) + else if (mapped_weno) then + alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) - alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, j)**2._wp + omega(0:weno_num_stencils)*(1._wp - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) - - elseif (wenoz) then - + alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + else if (wenoz) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - alpha(q) = d_cbR_${XYZ}$ (q, j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability + alpha(q) = d_cbR_${XYZ}$ (q, & + & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability end do - - elseif (teno) then + else if (teno) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = delta(q)*d_cbR_${XYZ}$ (q, j) @@ -1158,14 +1366,15 @@ contains omega = alpha/sum(alpha) - vR_rs_vf_${XYZ}$ (j, k, l, i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3)*poly(3) + vR_rs_vf_${XYZ}$ (j, k, l, & + & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3) & + & *poly(3) if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 vR_rs_vf_${XYZ}$ (j, k, l, i) = vR_rs_vf_${XYZ}$ (j, k, l, i) + omega(4)*poly(4) #:endif end if - end do end do end do @@ -1177,27 +1386,18 @@ contains end if if (int_comp) then - call s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, & - vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, & - weno_dir, is1_weno_d, is2_weno_d, is3_weno_d) + call s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, weno_dir, & + & is1_weno_d, is2_weno_d, is3_weno_d) end if - end subroutine s_weno - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are required for the setup of the - !! WENO reconstruction. + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other + !! procedures that are required for the setup of the WENO reconstruction. !! @param v_vf Cell-averaged variables !! @param weno_dir Coordinate direction of the WENO reconstruction - subroutine s_initialize_weno(v_vf, & - weno_dir) - - type(scalar_field), dimension(:), intent(IN) :: v_vf - - integer, intent(IN) :: weno_dir - - integer :: j, k, l, q + subroutine s_initialize_weno(v_vf, weno_dir) + type(scalar_field), dimension(:), intent(in) :: v_vf + integer, intent(in) :: weno_dir + integer :: j, k, l, q ! Determining the number of cell-average variables which will be ! WENO-reconstructed and mapping their indical bounds in the x-, @@ -1254,42 +1454,31 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - end subroutine s_initialize_weno - - !> The goal of this subroutine is to ensure that the WENO - !! reconstruction is monotonic. The latter is achieved by - !! enforcing monotonicity preserving bounds of Suresh and - !! Huynh (1997). The resulting MPWENO reconstruction, see - !! Balsara and Shu (2000), ensures that the reconstructed - !! values do not reside outside the range spanned by WENO - !! stencil. - !! @param v_rs_ws Reshaped cell-averaged variables - !! @param vL_rs_vf Left WENO reconstructed cell-boundary values - !! @param vR_rs_vf Right WENO reconstructed cell-boundary values + !> The goal of this subroutine is to ensure that the WENO reconstruction is monotonic. The latter is achieved by enforcing + !! monotonicity preserving bounds of Suresh and Huynh (1997). The resulting MPWENO reconstruction, see Balsara and Shu (2000), + !! ensures that the reconstructed values do not reside outside the range spanned by WENO stencil. + !! @param v_rs_ws Reshaped cell-averaged variables + !! @param vL_rs_vf Left WENO reconstructed cell-boundary values + !! @param vR_rs_vf Right WENO reconstructed cell-boundary values subroutine s_preserve_monotonicity(v_rs_ws, vL_rs_vf, vR_rs_vf) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(IN) :: v_rs_ws - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(INOUT) :: vL_rs_vf, vR_rs_vf - - integer :: i, j, k, l - - real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers - - real(wp) :: d_MD, d_LC !< + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: v_rs_ws + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf, vR_rs_vf + integer :: i, j, k, l + real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers + real(wp) :: d_MD, d_LC !< !! Median (md) curvature and large curvature (LC) measures ! The left and right upper bounds (UL), medians, large curvatures, ! minima, and maxima of the WENO-reconstructed values of the cell- ! average variables. - real(wp) :: vL_UL, vR_UL - real(wp) :: vL_MD, vR_MD - real(wp) :: vL_LC, vR_LC - real(wp) :: vL_min, vR_min - real(wp) :: vL_max, vR_max - + real(wp) :: vL_UL, vR_UL + real(wp) :: vL_MD, vR_MD + real(wp) :: vL_LC, vR_LC + real(wp) :: vL_min, vR_min + real(wp) :: vL_max, vR_max real(wp), parameter :: alpha = 2._wp !> - !! Determines the maximum Courant–Friedrichs–Lewy (CFL) number that + !! Determines the maximum Courant-Friedrichs-Lewy (CFL) number that !! may be utilized with the scheme. In theory, for stability, a CFL !! number less than 1/(1+alpha) is necessary. The default value for !! alpha is 2. @@ -1306,138 +1495,77 @@ contains do k = is2_weno%beg, is2_weno%end do j = is1_weno%beg, is1_weno%end do i = 1, v_size - d(-1) = v_rs_ws(j, k, l, i) & - + v_rs_ws(j - 2, k, l, i) & - - v_rs_ws(j - 1, k, l, i) & - *2._wp - d(0) = v_rs_ws(j + 1, k, l, i) & - + v_rs_ws(j - 1, k, l, i) & - - v_rs_ws(j, k, l, i) & - *2._wp - d(1) = v_rs_ws(j + 2, k, l, i) & - + v_rs_ws(j, k, l, i) & - - v_rs_ws(j + 1, k, l, i) & - *2._wp - - d_MD = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1))) & - *abs((sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1))) & - *(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, d(0)))) & - *min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), & - abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp - - d_LC = (sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, 4._wp*d(1) - d(0))) & - *abs((sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, d(0))) & - *(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, d(1)))) & - *min(abs(4._wp*d(0) - d(1)), abs(d(0)), & - abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp - - vL_UL = v_rs_ws(j, k, l, i) & - - (v_rs_ws(j + 1, k, l, i) & - - v_rs_ws(j, k, l, i))*alpha_mp - - vL_MD = (v_rs_ws(j, k, l, i) & - + v_rs_ws(j - 1, k, l, i) & - - d_MD)*5.e-1_wp - - vL_LC = v_rs_ws(j, k, l, i) & - - (v_rs_ws(j + 1, k, l, i) & - - v_rs_ws(j, k, l, i))*5.e-1_wp + beta_mp*d_LC - - vL_min = max(min(v_rs_ws(j, k, l, i), & - v_rs_ws(j - 1, k, l, i), & - vL_MD), & - min(v_rs_ws(j, k, l, i), & - vL_UL, & - vL_LC)) - - vL_max = min(max(v_rs_ws(j, k, l, i), & - v_rs_ws(j - 1, k, l, i), & - vL_MD), & - max(v_rs_ws(j, k, l, i), & - vL_UL, & - vL_LC)) - - vL_rs_vf(j, k, l, i) = vL_rs_vf(j, k, l, i) & - + (sign(5.e-1_wp, vL_min - vL_rs_vf(j, k, l, i)) & - + sign(5.e-1_wp, vL_max - vL_rs_vf(j, k, l, i))) & - *min(abs(vL_min - vL_rs_vf(j, k, l, i)), & - abs(vL_max - vL_rs_vf(j, k, l, i))) + d(-1) = v_rs_ws(j, k, l, i) + v_rs_ws(j - 2, k, l, i) - v_rs_ws(j - 1, k, l, i)*2._wp + d(0) = v_rs_ws(j + 1, k, l, i) + v_rs_ws(j - 1, k, l, i) - v_rs_ws(j, k, l, i)*2._wp + d(1) = v_rs_ws(j + 2, k, l, i) + v_rs_ws(j, k, l, i) - v_rs_ws(j + 1, k, l, i)*2._wp + + d_MD = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1)))*abs((sign(1._wp, & + & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & + & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp + + d_LC = (sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, 4._wp*d(1) - d(0)))*abs((sign(1._wp, & + & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & + & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp + + vL_UL = v_rs_ws(j, k, l, i) - (v_rs_ws(j + 1, k, l, i) - v_rs_ws(j, k, l, i))*alpha_mp + + vL_MD = (v_rs_ws(j, k, l, i) + v_rs_ws(j - 1, k, l, i) - d_MD)*5.e-1_wp + + vL_LC = v_rs_ws(j, k, l, i) - (v_rs_ws(j + 1, k, l, i) - v_rs_ws(j, k, l, i))*5.e-1_wp + beta_mp*d_LC + + vL_min = max(min(v_rs_ws(j, k, l, i), v_rs_ws(j - 1, k, l, i), vL_MD), min(v_rs_ws(j, k, l, i), vL_UL, & + & vL_LC)) + + vL_max = min(max(v_rs_ws(j, k, l, i), v_rs_ws(j - 1, k, l, i), vL_MD), max(v_rs_ws(j, k, l, i), vL_UL, & + & vL_LC)) + + vL_rs_vf(j, k, l, i) = vL_rs_vf(j, k, l, i) + (sign(5.e-1_wp, vL_min - vL_rs_vf(j, k, l, & + & i)) + sign(5.e-1_wp, vL_max - vL_rs_vf(j, k, l, i)))*min(abs(vL_min - vL_rs_vf(j, k, l, i)), & + & abs(vL_max - vL_rs_vf(j, k, l, i))) ! END: Left Monotonicity Preserving Bound ! Right Monotonicity Preserving Bound - d(-1) = v_rs_ws(j, k, l, i) & - + v_rs_ws(j - 2, k, l, i) & - - v_rs_ws(j - 1, k, l, i) & - *2._wp - d(0) = v_rs_ws(j + 1, k, l, i) & - + v_rs_ws(j - 1, k, l, i) & - - v_rs_ws(j, k, l, i) & - *2._wp - d(1) = v_rs_ws(j + 2, k, l, i) & - + v_rs_ws(j, k, l, i) & - - v_rs_ws(j + 1, k, l, i) & - *2._wp - - d_MD = (sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, 4._wp*d(1) - d(0))) & - *abs((sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, d(0))) & - *(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, d(1)))) & - *min(abs(4._wp*d(0) - d(1)), abs(d(0)), & - abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp - - d_LC = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1))) & - *abs((sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1))) & - *(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, d(0)))) & - *min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), & - abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp - - vR_UL = v_rs_ws(j, k, l, i) & - + (v_rs_ws(j, k, l, i) & - - v_rs_ws(j - 1, k, l, i))*alpha_mp - - vR_MD = (v_rs_ws(j, k, l, i) & - + v_rs_ws(j + 1, k, l, i) & - - d_MD)*5.e-1_wp - - vR_LC = v_rs_ws(j, k, l, i) & - + (v_rs_ws(j, k, l, i) & - - v_rs_ws(j - 1, k, l, i))*5.e-1_wp + beta_mp*d_LC - - vR_min = max(min(v_rs_ws(j, k, l, i), & - v_rs_ws(j + 1, k, l, i), & - vR_MD), & - min(v_rs_ws(j, k, l, i), & - vR_UL, & - vR_LC)) - - vR_max = min(max(v_rs_ws(j, k, l, i), & - v_rs_ws(j + 1, k, l, i), & - vR_MD), & - max(v_rs_ws(j, k, l, i), & - vR_UL, & - vR_LC)) - - vR_rs_vf(j, k, l, i) = vR_rs_vf(j, k, l, i) & - + (sign(5.e-1_wp, vR_min - vR_rs_vf(j, k, l, i)) & - + sign(5.e-1_wp, vR_max - vR_rs_vf(j, k, l, i))) & - *min(abs(vR_min - vR_rs_vf(j, k, l, i)), & - abs(vR_max - vR_rs_vf(j, k, l, i))) + d(-1) = v_rs_ws(j, k, l, i) + v_rs_ws(j - 2, k, l, i) - v_rs_ws(j - 1, k, l, i)*2._wp + d(0) = v_rs_ws(j + 1, k, l, i) + v_rs_ws(j - 1, k, l, i) - v_rs_ws(j, k, l, i)*2._wp + d(1) = v_rs_ws(j + 2, k, l, i) + v_rs_ws(j, k, l, i) - v_rs_ws(j + 1, k, l, i)*2._wp + + d_MD = (sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, 4._wp*d(1) - d(0)))*abs((sign(1._wp, & + & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & + & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp + + d_LC = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1)))*abs((sign(1._wp, & + & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & + & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp + + vR_UL = v_rs_ws(j, k, l, i) + (v_rs_ws(j, k, l, i) - v_rs_ws(j - 1, k, l, i))*alpha_mp + + vR_MD = (v_rs_ws(j, k, l, i) + v_rs_ws(j + 1, k, l, i) - d_MD)*5.e-1_wp + + vR_LC = v_rs_ws(j, k, l, i) + (v_rs_ws(j, k, l, i) - v_rs_ws(j - 1, k, l, i))*5.e-1_wp + beta_mp*d_LC + + vR_min = max(min(v_rs_ws(j, k, l, i), v_rs_ws(j + 1, k, l, i), vR_MD), min(v_rs_ws(j, k, l, i), vR_UL, & + & vR_LC)) + + vR_max = min(max(v_rs_ws(j, k, l, i), v_rs_ws(j + 1, k, l, i), vR_MD), max(v_rs_ws(j, k, l, i), vR_UL, & + & vR_LC)) + + vR_rs_vf(j, k, l, i) = vR_rs_vf(j, k, l, i) + (sign(5.e-1_wp, vR_min - vR_rs_vf(j, k, l, & + & i)) + sign(5.e-1_wp, vR_max - vR_rs_vf(j, k, l, i)))*min(abs(vR_min - vR_rs_vf(j, k, l, i)), & + & abs(vR_max - vR_rs_vf(j, k, l, i))) ! END: Right Monotonicity Preserving Bound end do end do end do end do $:END_GPU_PARALLEL_LOOP() - end subroutine s_preserve_monotonicity - - !> Module deallocation and/or disassociation procedures + !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_weno_module() - if (weno_order == 1) return ! Deallocating the WENO-stencil of the WENO-reconstructed variables - !deallocate(vL_rs_vf_x, vR_rs_vf_x) + ! deallocate(vL_rs_vf_x, vR_rs_vf_x) @:DEALLOCATE(v_rs_ws_x) ! Deallocating WENO coefficients in x-direction @@ -1448,7 +1576,7 @@ contains ! Deallocating WENO coefficients in y-direction if (n == 0) return - !deallocate(vL_rs_vf_y, vR_rs_vf_y) + ! deallocate(vL_rs_vf_y, vR_rs_vf_y) @:DEALLOCATE(v_rs_ws_y) @:DEALLOCATE(poly_coef_cbL_y, poly_coef_cbR_y) @@ -1458,13 +1586,11 @@ contains ! Deallocating WENO coefficients in z-direction if (p == 0) return - !deallocate(vL_rs_vf_z, vR_rs_vf_z) + ! deallocate(vL_rs_vf_z, vR_rs_vf_z) @:DEALLOCATE(v_rs_ws_z) @:DEALLOCATE(poly_coef_cbL_z, poly_coef_cbR_z) @:DEALLOCATE(d_cbL_z, d_cbR_z) @:DEALLOCATE(beta_coef_z) - end subroutine s_finalize_weno_module - end module m_weno diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index e65722e191..a17827a5aa 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -2,18 +2,13 @@ !! @file !! @brief Contains program p_main -!> @brief Quasi-conservative, shock- and interface- capturing finite-volume -!! scheme for the multicomponent Navier-Stokes equations. The system -!! is augmented with the relevant advection equations to capture the -!! material interfaces and closed by the stiffened equation of state -!! as well as any required mixture relations. The effects of surface -!! tension are included and modeled through a volume force that acts -!! across the diffuse material interface regions. The implementation -!! specifics of surface tension may be found in the work by Perigaud -!! and Saurel (2005). Note that both viscous and capillarity effects -!! are only available in the volume fraction model. +!> @brief Quasi-conservative, shock- and interface- capturing finite-volume scheme for the multicomponent Navier-Stokes equations. +!! The system is augmented with the relevant advection equations to capture the material interfaces and closed by the stiffened +!! equation of state as well as any required mixture relations. The effects of surface tension are included and modeled through a +!! volume force that acts across the diffuse material interface regions. The implementation specifics of surface tension may be +!! found in the work by Perigaud and Saurel (2005). Note that both viscous and capillarity effects are only available in the volume +!! fraction model. program p_main - use m_global_parameters !< Definitions of the global parameters use m_start_up @@ -24,25 +19,25 @@ program p_main implicit none - integer :: t_step !< Iterator for the time-stepping loop - real(wp) :: time_avg, time_final - real(wp) :: io_time_avg, io_time_final + integer :: t_step !< Iterator for the time-stepping loop + real(wp) :: time_avg, time_final + real(wp) :: io_time_avg, io_time_final real(wp), allocatable, dimension(:) :: proc_time real(wp), allocatable, dimension(:) :: io_proc_time - logical :: file_exists - real(wp) :: start, finish - integer :: nt + logical :: file_exists + real(wp) :: start, finish + integer :: nt call system_clock(COUNT=cpu_start, COUNT_RATE=cpu_rate) call nvtxStartRange("INIT") - !Initialize MPI + ! Initialize MPI call nvtxStartRange("INIT-MPI") call s_initialize_mpi_domain() call nvtxEndRange - !Initialize Modules + ! Initialize Modules call nvtxStartRange("INIT-MODULES") call s_initialize_modules() call nvtxEndRange @@ -73,17 +68,16 @@ program p_main call nvtxStartRange("SIMULATION-TIME-MARCH") ! Time-stepping Loop do - if (cfl_dt) then if (mytime >= t_stop) then - call s_save_performance_metrics(time_avg, time_final, io_time_avg, & - io_time_final, proc_time, io_proc_time, file_exists) + call s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & + & file_exists) exit end if else if (t_step == t_step_stop) then - call s_save_performance_metrics(time_avg, time_final, io_time_avg, & - io_time_final, proc_time, io_proc_time, file_exists) + call s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & + & file_exists) exit end if end if @@ -110,5 +104,4 @@ program p_main call nvtxStartRange("FINALIZE-MODULES") call s_finalize_modules() call nvtxEndRange - end program p_main diff --git a/src/syscheck/syscheck.fpp b/src/syscheck/syscheck.fpp index 75e18efc33..7ba5543be5 100644 --- a/src/syscheck/syscheck.fpp +++ b/src/syscheck/syscheck.fpp @@ -58,7 +58,6 @@ #:enddef OMP program syscheck - @:MPI(use mpi) @:ACC(use openacc) @:OMP(use omp_lib) @@ -102,11 +101,9 @@ program syscheck @:LOG("") @:LOG("Syscheck: PASSED.") - end program syscheck subroutine assert(condition) - use iso_fortran_env, only: output_unit, error_unit logical, intent(in) :: condition @@ -116,5 +113,4 @@ subroutine assert(condition) call flush (int(error_unit)) stop 1 end if - end subroutine assert diff --git a/toolchain/bootstrap/format.sh b/toolchain/bootstrap/format.sh index ce500ab301..962fe5d7a9 100644 --- a/toolchain/bootstrap/format.sh +++ b/toolchain/bootstrap/format.sh @@ -51,59 +51,10 @@ else PYTHON_DIRS="toolchain/ examples/ benchmarks/" fi -# Format Fortran files (.f90, .fpp) -FORTRAN_FILES=$(find $FORTRAN_DIRS -type f 2>/dev/null | grep -Ev 'autogen' | grep -E '\.(f90|fpp)$' || true) -if [[ -n "$FORTRAN_FILES" ]]; then - FPRETTIFY_OPTS="--silent --indent 4 --c-relations --enable-replacements --enable-decl --whitespace-comma 1 --whitespace-multdiv 0 --whitespace-plusminus 1 --case 1 1 1 1 --strict-indent --line-length 1000" - - # Skip files unchanged since last format (hash cache in build/.cache/format/) - CACHE_DIR="build/.cache/format" - mkdir -p "$CACHE_DIR" - DIRTY_FILES="" - for f in $FORTRAN_FILES; do - cache_key=$(echo "$f" | tr '/' '_') - current_hash=$(md5sum "$f" | cut -d' ' -f1) - cached_hash=$(cat "$CACHE_DIR/$cache_key" 2>/dev/null || true) - if [[ "$current_hash" != "$cached_hash" ]]; then - DIRTY_FILES+="$f"$'\n' - fi - done - DIRTY_FILES=$(echo "$DIRTY_FILES" | sed '/^$/d') - - if [[ -n "$DIRTY_FILES" ]]; then - for niter in 1 2 3 4; do - old_hash=$(echo "$DIRTY_FILES" | xargs cat | md5sum) - - # Run indenter on dirty files in one process - if ! echo "$DIRTY_FILES" | xargs python3 toolchain/indenter.py; then - error "Formatting Fortran files failed: indenter.py." - exit 1 - fi - - # Run fprettify in parallel (one process per file) - if ! echo "$DIRTY_FILES" | xargs -P ${JOBS:-1} -L 1 fprettify $FPRETTIFY_OPTS; then - error "Formatting Fortran files failed: fprettify." - exit 1 - fi - - new_hash=$(echo "$DIRTY_FILES" | xargs cat | md5sum) - if [[ "$old_hash" == "$new_hash" ]]; then - break - fi - if [[ "$niter" -eq 4 ]]; then - error "Formatting Fortran files failed: no steady-state after $niter iterations." - exit 1 - fi - done - - # Update hash cache for formatted files - for f in $DIRTY_FILES; do - cache_key=$(echo "$f" | tr '/' '_') - md5sum "$f" | cut -d' ' -f1 > "$CACHE_DIR/$cache_key" - done - - echo "$DIRTY_FILES" | while read -r f; do echo "> $f"; done - fi +# Format Fortran files with ffmt (single-pass, idempotent) +if ! ffmt -j ${JOBS:-1} $FORTRAN_DIRS 2>/dev/null; then + error "Formatting Fortran files failed: ffmt." + exit 1 fi # Apply safe auto-fixes (import sorting, etc.) before formatting. diff --git a/toolchain/indenter.py b/toolchain/indenter.py deleted file mode 100644 index ab0203ae4e..0000000000 --- a/toolchain/indenter.py +++ /dev/null @@ -1,83 +0,0 @@ -#!/usr/bin/env python3 - -import argparse -import os - - -def main(): - parser = argparse.ArgumentParser(prog="indenter.py", description="Adjust indentation of OpenACC directives in Fortran files") - parser.add_argument("filepaths", metavar="input_file", type=str, nargs="+", help="Files to format") - args = parser.parse_args() - - for filepath in args.filepaths: - temp_filepath = f"{filepath}.new" - adjust_indentation(filepath, temp_filepath) - os.replace(temp_filepath, filepath) - - -BLOCK_STARTERS = ("if", "do", "#:if", "#:else", "#ifdef", "#else") -BLOCK_ENDERS = ("end", "contains", "else", "#:end", "#:else", "#else", "#endif") -LOOP_DIRECTIVES = ("!$acc loop", "!$acc parallel loop") -INDENTERS = ("!DIR", "!$acc") - - -def adjust_indentation(input_file, output_file): - max_empty_lines = 4 - indent_len = 4 - - with open(input_file, "r") as file_in, open(output_file, "w") as file_out: - lines = file_in.readlines() - - # this makes sure !$acc lines that have line continuations get indented at proper level - for _ in range(10): - # loop through file - for i in range(len(lines)): - if lines[i].lstrip().startswith(INDENTERS) and i + 1 < len(lines): - j = i + 1 - empty_lines = 0 - # look down to see how to indent a line - while j < len(lines) and empty_lines < max_empty_lines: - # if the following line starts with [end, else, contains], skip to looking up - if lines[j].lstrip().startswith(BLOCK_ENDERS): - empty_lines = max_empty_lines - # skip empty lines - elif lines[j].strip() == "": - empty_lines += 1 - # indent acc lines - elif not lines[j].lstrip().startswith(INDENTERS): - indent = len(lines[j]) - len(lines[j].lstrip()) - lines[i] = " " * indent + lines[i].lstrip() - break - j += 1 - # if looking down just finds empty lines, start looking up for indentation level - if empty_lines == max_empty_lines: - k = i - 1 - while k >= 0: - # if line above is not empty - if lines[k].strip() != "": - # if line 2 above ends with line continuation, indent at that level - if lines[k - 1].strip().endswith("&"): - indent = len(lines[k - 1]) - len(lines[k - 1].lstrip()) - # if line above starts a loop or branch, indent - elif lines[k].lstrip().startswith(BLOCK_STARTERS): - indent = indent_len + (len(lines[k]) - len(lines[k].lstrip())) - # else indent at level of line above - else: - indent = len(lines[k]) - len(lines[k].lstrip()) - lines[i] = " " * indent + lines[i].lstrip() - break - k -= 1 - - # remove empty lines following an acc loop directive - i = 0 - while i < len(lines): - if lines[i].lstrip().startswith(LOOP_DIRECTIVES) and i + 1 < len(lines) and lines[i + 1].strip() == "": - file_out.write(lines[i]) - i += 2 - else: - file_out.write(lines[i]) - i += 1 - - -if __name__ == "__main__": - main() diff --git a/toolchain/pyproject.toml b/toolchain/pyproject.toml index 74611d3442..fe9b7b7fee 100644 --- a/toolchain/pyproject.toml +++ b/toolchain/pyproject.toml @@ -24,7 +24,7 @@ dependencies = [ # Code Health "typos", "ruff", - "fprettify", + "ffmt", "ansi2txt", # Profiling From d9d7ee2c896e4052bbf0facebf97b960102e13b8 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 01:18:14 -0400 Subject: [PATCH 02/25] Apply ffmt formatting with comment alignment and idempotency fixes --- src/common/include/2dHardcodedIC.fpp | 28 +- src/common/include/3dHardcodedIC.fpp | 2 +- src/common/include/macros.fpp | 2 +- src/common/m_boundary_common.fpp | 44 +- src/common/m_checker_common.fpp | 6 +- src/common/m_chemistry.fpp | 15 +- src/common/m_compile_specific.f90 | 5 + src/common/m_constants.fpp | 70 +- src/common/m_derived_types.fpp | 147 ++- src/common/m_finite_differences.fpp | 19 +- src/common/m_helper.fpp | 52 +- src/common/m_helper_basic.fpp | 8 +- src/common/m_model.fpp | 37 +- src/common/m_mpi_common.fpp | 111 ++- src/common/m_nvtx.f90 | 3 +- src/common/m_phase_change.fpp | 51 +- src/common/m_variables_conversion.fpp | 68 +- src/post_process/m_checker.fpp | 4 +- src/post_process/m_data_input.f90 | 14 +- src/post_process/m_data_output.fpp | 76 +- src/post_process/m_derived_variables.fpp | 84 +- src/post_process/m_global_parameters.fpp | 111 +-- src/post_process/m_mpi_proxy.fpp | 37 +- src/post_process/m_start_up.fpp | 58 +- src/post_process/p_main.fpp | 2 +- src/pre_process/m_assign_variables.fpp | 41 +- src/pre_process/m_boundary_conditions.fpp | 6 +- src/pre_process/m_check_ib_patches.fpp | 20 +- src/pre_process/m_check_patches.fpp | 28 +- src/pre_process/m_checker.fpp | 3 - src/pre_process/m_data_output.fpp | 47 +- src/pre_process/m_global_parameters.fpp | 147 +-- src/pre_process/m_grid.f90 | 22 +- src/pre_process/m_icpp_patches.fpp | 76 +- src/pre_process/m_initial_condition.fpp | 14 +- src/pre_process/m_mpi_proxy.fpp | 3 - src/pre_process/m_perturbation.fpp | 28 +- src/pre_process/m_simplex_noise.fpp | 53 +- src/pre_process/m_start_up.fpp | 32 +- src/pre_process/p_main.f90 | 1 - src/simulation/include/inline_riemann.fpp | 8 +- src/simulation/m_acoustic_src.fpp | 52 +- src/simulation/m_body_forces.fpp | 7 +- src/simulation/m_bubbles.fpp | 73 +- src/simulation/m_bubbles_EE.fpp | 25 +- src/simulation/m_bubbles_EL.fpp | 136 +-- src/simulation/m_bubbles_EL_kernels.fpp | 18 +- src/simulation/m_cbc.fpp | 154 ++- src/simulation/m_checker.fpp | 8 +- src/simulation/m_compute_cbc.fpp | 12 + src/simulation/m_compute_levelset.fpp | 48 +- src/simulation/m_data_output.fpp | 165 ++-- src/simulation/m_derived_variables.fpp | 71 +- src/simulation/m_fftw.fpp | 24 +- src/simulation/m_global_parameters.fpp | 273 +++--- src/simulation/m_hyperelastic.fpp | 13 +- src/simulation/m_hypoelastic.fpp | 128 +-- src/simulation/m_ib_patches.fpp | 54 +- src/simulation/m_ibm.fpp | 133 +-- src/simulation/m_igr.fpp | 839 ++++++++-------- src/simulation/m_mpi_proxy.fpp | 11 +- src/simulation/m_muscl.fpp | 27 +- src/simulation/m_pressure_relaxation.fpp | 9 +- src/simulation/m_qbmm.fpp | 160 +-- src/simulation/m_rhs.fpp | 197 ++-- src/simulation/m_riemann_solvers.fpp | 1078 ++++++++++----------- src/simulation/m_sim_helpers.fpp | 10 +- src/simulation/m_start_up.fpp | 71 +- src/simulation/m_surface_tension.fpp | 28 +- src/simulation/m_time_steppers.fpp | 90 +- src/simulation/m_viscous.fpp | 184 ++-- src/simulation/m_weno.fpp | 1039 ++++++++++---------- src/simulation/p_main.fpp | 7 +- 73 files changed, 3370 insertions(+), 3357 deletions(-) diff --git a/src/common/include/2dHardcodedIC.fpp b/src/common/include/2dHardcodedIC.fpp index 8354bb61b9..183bcc059d 100644 --- a/src/common/include/2dHardcodedIC.fpp +++ b/src/common/include/2dHardcodedIC.fpp @@ -228,7 +228,7 @@ ! pressure q_prim_vf(E_idx)%sf(i, j, & - & 0) = 1._wp + (1 - 2._wp*(x_cc(i)**2 + y_cc(j)**2))*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/((2._wp*pi)**3) + & 0) = 1._wp + (1 - 2._wp*(x_cc(i)**2 + y_cc(j)**2))*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/((2._wp*pi)**3) case (260) ! Gaussian Divergence Pulse ! Bx(x) = 1 + C * erf((x-0.5)/\sigma) ! => \partialBx/\partialx = C * (2/\sqrt\pi) * exp[-((x-0.5)/\sigma)**2] * (1/\sigma) @@ -287,17 +287,17 @@ ! This analytic patch uses geometry 2 if (patch_id == 1) then q_prim_vf(E_idx)%sf(i, j, & - & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & - & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**(1.4 + 1.0) + & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & + & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**(1.4 + 1.0) q_prim_vf(contxb + 0)%sf(i, j, & - & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & - & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**1.4 + & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & + & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**1.4 q_prim_vf(momxb + 0)%sf(i, j, & - & 0) = 0.0 + (y_cc(j) - patch_icpp(1)%y_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & - & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) + & 0) = 0.0 + (y_cc(j) - patch_icpp(1)%y_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & + & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) q_prim_vf(momxb + 1)%sf(i, j, & - & 0) = 0.0 - (x_cc(i) - patch_icpp(1)%x_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & - & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) + & 0) = 0.0 - (x_cc(i) - patch_icpp(1)%x_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & + & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) end if case (281) ! This is patch is hard-coded for test suite optimization used in the @@ -305,9 +305,9 @@ ! This analytic patch uses geometry 2 if (patch_id == 2) then q_prim_vf(E_idx)%sf(i, j, & - & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) + & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) q_prim_vf(contxb + 0)%sf(i, j, & - & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) + & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) end if case (282) ! This is patch is hard-coded for test suite optimization used in the @@ -315,11 +315,11 @@ ! This analytic patch uses geometry 2 if (patch_id == 2) then q_prim_vf(E_idx)%sf(i, j, & - & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) + & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) q_prim_vf(contxb + 0)%sf(i, j, & - & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) + & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) q_prim_vf(momxb + 0)%sf(i, j, & - & 0) = 112.99092883944267*(1 - (0.1/0.3))*y_cc(j)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) + & 0) = 112.99092883944267*(1 - (0.1/0.3))*y_cc(j)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) q_prim_vf(momxb + 1)%sf(i, j, 0) = 112.99092883944267*((0.1/0.3))*x_cc(i)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) end if case default diff --git a/src/common/include/3dHardcodedIC.fpp b/src/common/include/3dHardcodedIC.fpp index 115123f1f6..a689831dcb 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -177,7 +177,7 @@ Mach = 0.1 if (patch_id == 1) then q_prim_vf(E_idx)%sf(i, j, & - & k) = 101325 + (Mach**2*376.636429464809**2/16)*(cos(2*x_cc(i)/1) + cos(2*y_cc(j)/1))*(cos(2*z_cc(k)/1) + 2) + & k) = 101325 + (Mach**2*376.636429464809**2/16)*(cos(2*x_cc(i)/1) + cos(2*y_cc(j)/1))*(cos(2*z_cc(k)/1) + 2) q_prim_vf(momxb + 0)%sf(i, j, k) = Mach*376.636429464809*sin(x_cc(i)/1)*cos(y_cc(j)/1)*sin(z_cc(k)/1) q_prim_vf(momxb + 1)%sf(i, j, k) = -Mach*376.636429464809*cos(x_cc(i)/1)*sin(y_cc(j)/1)*sin(z_cc(k)/1) end if diff --git a/src/common/include/macros.fpp b/src/common/include/macros.fpp index c2bc2111c1..3897cb88d8 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -157,7 +157,7 @@ #:def ASSERT(predicate, message = None) if (.not. (${predicate}$)) then call s_mpi_abort("${_FILE_.split('/')[-1]}$:${_LINE_}$: " // "Assertion failed: ${predicate}$. " & - & // ${message or '"No error description."'}$) + & // ${message or '"No error description."'}$) end if #:enddef ! New line at end of file is required for FYPP diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index b9221643fd..18c07b49a4 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -8,15 +8,10 @@ module m_boundary_common use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy - use m_constants - use m_delay_file_access - use m_compile_specific implicit none @@ -70,6 +65,7 @@ contains end do end if end subroutine s_initialize_boundary_common_module + !> The purpose of this procedure is to populate the buffers of the primitive variables, depending on the selected boundary !! conditions. impure subroutine s_populate_variables_buffers(bc_type, q_prim_vf, pb_in, mv_in) @@ -269,6 +265,7 @@ contains #:endif ! END: Population of Buffers in z-direction end subroutine s_populate_variables_buffers + !> @brief Fills ghost cells by copying the nearest boundary cell value along the specified direction. subroutine s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_ghost_cell_extrapolation', parallelism='[seq]', cray_inline=True) @@ -321,6 +318,7 @@ contains end if end if end subroutine s_ghost_cell_extrapolation + !> @brief Applies reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the normal velocity !! component. subroutine s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) @@ -347,7 +345,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(1, i))%sf(-j, k, l) = -q_prim_vf(shear_BC_flip_indices(1, & - & i))%sf(j - 1, k, l) + & i))%sf(j - 1, k, l) end do end if @@ -381,7 +379,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(1, i))%sf(m + j, k, l) = -q_prim_vf(shear_BC_flip_indices(1, & - & i))%sf(m - (j - 1), k, l) + & i))%sf(m - (j - 1), k, l) end do end if @@ -416,7 +414,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, -j, l) = -q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, & - & j - 1, l) + & j - 1, l) end do end if @@ -450,7 +448,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, n + j, l) = -q_prim_vf(shear_BC_flip_indices(2, & - & i))%sf(k, n - (j - 1), l) + & i))%sf(k, n - (j - 1), l) end do end if @@ -486,7 +484,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, -j) = -q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, & - & l, j - 1) + & l, j - 1) end do end if @@ -520,7 +518,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, p + j) = -q_prim_vf(shear_BC_flip_indices(3, & - & i))%sf(k, l, p - (j - 1)) + & i))%sf(k, l, p - (j - 1)) end do end if @@ -542,6 +540,7 @@ contains end if end if end subroutine s_symmetry + !> @brief Applies periodic boundary conditions by copying values from the opposite domain boundary. subroutine s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') @@ -661,6 +660,7 @@ contains end if end if end subroutine s_periodic + !> @brief Applies axis boundary conditions for cylindrical coordinates by reflecting values across the axis with azimuthal phase !! shift. subroutine s_axis(q_prim_vf, pb_in, mv_in, k, l) @@ -709,6 +709,7 @@ contains end do end if end subroutine s_axis + !> @brief Applies slip wall boundary conditions by extrapolating scalars and reflecting the wall-normal velocity component. subroutine s_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_slip_wall',parallelism='[seq]', cray_inline=True) @@ -785,6 +786,7 @@ contains end if end if end subroutine s_slip_wall + !> @brief Applies no-slip wall boundary conditions by reflecting and negating all velocity components at the wall. subroutine s_no_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_no_slip_wall',parallelism='[seq]', cray_inline=True) @@ -886,6 +888,7 @@ contains end if end if end subroutine s_no_slip_wall + !> @brief Applies Dirichlet boundary conditions by prescribing ghost cell values from stored boundary buffers. subroutine s_dirichlet(q_prim_vf, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_dirichlet',parallelism='[seq]', cray_inline=True) @@ -946,6 +949,7 @@ contains call s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l) #endif end subroutine s_dirichlet + !> @brief Extrapolates QBMM bubble pressure and mass-vapor variables into ghost cells by copying boundary values. subroutine s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') @@ -1016,6 +1020,7 @@ contains end if end if end subroutine s_qbmm_extrapolation + !> @brief Populates ghost cell buffers for the color function and its divergence used in capillary surface tension. impure subroutine s_populate_capillary_buffers(c_divs, bc_type) type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs @@ -1147,6 +1152,7 @@ contains end if #:endif end subroutine s_populate_capillary_buffers + !> @brief Applies periodic boundary conditions to the color function and its divergence fields. subroutine s_color_function_periodic(c_divs, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_color_function_periodic', parallelism='[seq]', cray_inline=True) @@ -1199,6 +1205,7 @@ contains end if end if end subroutine s_color_function_periodic + !> @brief Applies reflective boundary conditions to the color function and its divergence fields. subroutine s_color_function_reflective(c_divs, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_color_function_reflective', parallelism='[seq]', cray_inline=True) @@ -1275,6 +1282,7 @@ contains end if end if end subroutine s_color_function_reflective + !> @brief Extrapolates the color function and its divergence into ghost cells by copying boundary values. subroutine s_color_function_ghost_cell_extrapolation(c_divs, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_color_function_ghost_cell_extrapolation', parallelism='[seq]', cray_inline=True) @@ -1327,6 +1335,7 @@ contains end if end if end subroutine s_color_function_ghost_cell_extrapolation + !> @brief Populates ghost cell buffers for the Jacobian scalar field used in the IGR elliptic solver. impure subroutine s_populate_F_igr_buffers(bc_type, jac_sf) type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type @@ -1491,6 +1500,7 @@ contains end if #:endif end subroutine s_populate_F_igr_buffers + !> @brief Creates MPI derived datatypes for boundary condition type arrays and buffer arrays used in parallel I/O. impure subroutine s_create_mpi_types(bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type @@ -1506,7 +1516,7 @@ contains sf_extents_loc = shape(bc_type(dir, loc)%sf) call MPI_TYPE_CREATE_SUBARRAY(num_dims, sf_extents_loc, sf_extents_loc, sf_start_idx, MPI_ORDER_FORTRAN, & - & MPI_INTEGER, MPI_BC_TYPE_TYPE(dir, loc), ierr) + & MPI_INTEGER, MPI_BC_TYPE_TYPE(dir, loc), ierr) call MPI_TYPE_COMMIT(MPI_BC_TYPE_TYPE(dir, loc), ierr) end do end do @@ -1517,12 +1527,13 @@ contains sf_extents_loc = shape(bc_buffers(dir, loc)%sf) call MPI_TYPE_CREATE_SUBARRAY(num_dims, sf_extents_loc*mpi_io_type, sf_extents_loc*mpi_io_type, sf_start_idx, & - & MPI_ORDER_FORTRAN, mpi_io_p, MPI_BC_BUFFER_TYPE(dir, loc), ierr) + & MPI_ORDER_FORTRAN, mpi_io_p, MPI_BC_BUFFER_TYPE(dir, loc), ierr) call MPI_TYPE_COMMIT(MPI_BC_BUFFER_TYPE(dir, loc), ierr) end do end do #endif end subroutine s_create_mpi_types + !> @brief Writes boundary condition type and buffer data to serial (unformatted) restart files. subroutine s_write_serial_boundary_condition_files(q_prim_vf, bc_type, step_dirpath, old_grid_in) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1559,6 +1570,7 @@ contains end do close (1) end subroutine s_write_serial_boundary_condition_files + !> @brief Writes boundary condition type and buffer data to per-rank parallel files using MPI I/O. subroutine s_write_parallel_boundary_condition_files(q_prim_vf, bc_type) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1621,6 +1633,7 @@ contains call MPI_File_close(file_id, ierr) #endif end subroutine s_write_parallel_boundary_condition_files + !> @brief Reads boundary condition type and buffer data from serial (unformatted) restart files. subroutine s_read_serial_boundary_condition_files(step_dirpath, bc_type) character(LEN=*), intent(in) :: step_dirpath @@ -1662,6 +1675,7 @@ contains end do close (1) end subroutine s_read_serial_boundary_condition_files + !> @brief Reads boundary condition type and buffer data from per-rank parallel files using MPI I/O. subroutine s_read_parallel_boundary_condition_files(bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type @@ -1724,6 +1738,7 @@ contains call MPI_File_close(file_id, ierr) #endif end subroutine s_read_parallel_boundary_condition_files + !> @brief Packs primitive variable boundary slices into bc_buffers arrays for serialization. subroutine s_pack_boundary_condition_buffers(q_prim_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1764,6 +1779,7 @@ contains end if #:endif end subroutine s_pack_boundary_condition_buffers + !> @brief Initializes the per-cell boundary condition type arrays with the global default BC values. subroutine s_assign_default_bc_type(bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type @@ -1787,6 +1803,7 @@ contains end if #:endif end subroutine s_assign_default_bc_type + !> The purpose of this subroutine is to populate the buffers of the grid variables, which are constituted of the cell- boundary !! locations and cell-width distributions, based on the boundary conditions. subroutine s_populate_grid_variables_buffers @@ -1971,6 +1988,7 @@ contains ! END: Population of Buffers in z-direction #endif end subroutine s_populate_grid_variables_buffers + !> @brief Deallocates boundary condition buffer arrays allocated during module initialization. subroutine s_finalize_boundary_common_module() if (bc_io) then diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index 38907b380f..48c4b7b2de 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -8,11 +8,8 @@ !> @brief Shared input validation checks for grid dimensions and AMD GPU compiler limits module m_checker_common use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers - use m_helper implicit none @@ -29,6 +26,7 @@ contains call s_check_amd #:endif end subroutine s_check_inputs_common + #ifndef MFC_SIMULATION !> @brief Verifies that the total number of grid cells meets the minimum required by the number of dimensions and MPI ranks. @@ -41,6 +39,7 @@ contains @:PROHIBIT(nGlobal < min_cells, "Total number of cells must be at least (2^[number of dimensions])*num_procs, " // "which is currently "//trim(numStr)) end subroutine s_check_total_cells + #endif !> @brief Checks that simulation parameters stay within AMD GPU compiler limits when case optimization is disabled. @@ -51,6 +50,7 @@ contains @:PROHIBIT(chemistry .and. num_species /= 10, "num_species = 10 for AMDFLang when Case optimization is off") #:endif end subroutine s_check_amd + #ifndef MFC_POST_PROCESS #endif end module m_checker_common diff --git a/src/common/m_chemistry.fpp b/src/common/m_chemistry.fpp index 584c121f7a..51755b2762 100644 --- a/src/common/m_chemistry.fpp +++ b/src/common/m_chemistry.fpp @@ -19,7 +19,7 @@ module m_chemistry #:if USING_AMD real(wp) :: molecular_weights_nonparameter(10) = (/2.016, 1.008, 15.999, 31.998, 17.007, 18.015, 33.006, 34.014, 39.95, & - & 28.014/) + & 28.014/) $:GPU_DECLARE(create='[molecular_weights_nonparameter]') #:endif @@ -41,6 +41,7 @@ contains Re_L = 1.0_wp/Re_L Re_R = 1.0_wp/Re_R end subroutine compute_viscosity_and_inversion + !> @brief Initializes the temperature field from conservative variables by inverting the energy equation. subroutine s_compute_q_T_sf(q_T_sf, q_cons_vf, bounds) ! Initialize the temperature field at the start of the simulation to @@ -77,6 +78,7 @@ contains end do end do end subroutine s_compute_q_T_sf + !> @brief Computes the temperature field from primitive variables using the ideal gas law and mixture molecular weight. subroutine s_compute_T_from_primitives(q_T_sf, q_prim_vf, bounds) type(scalar_field), intent(inout) :: q_T_sf @@ -99,6 +101,7 @@ contains end do end do end subroutine s_compute_T_from_primitives + !> @brief Adds chemical reaction source terms to the species transport RHS using net production rates. subroutine s_compute_chemistry_reaction_flux(rhs_vf, q_cons_qp, q_T_sf, q_prim_qp, bounds) type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf @@ -145,6 +148,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_compute_chemistry_reaction_flux + !> @brief Computes species mass diffusion fluxes at cell interfaces using mixture-averaged diffusivities. subroutine s_compute_chemistry_diffusion_flux(idir, q_prim_qp, flux_src_vf, irx, iry, irz) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_qp @@ -263,7 +267,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe mass_diffusivities_mixavg_Cell(i - chemxb + 1) = (mass_diffusivities_mixavg2(i - chemxb + 1) & - & + mass_diffusivities_mixavg1(i - chemxb + 1))/2.0_wp + & + mass_diffusivities_mixavg1(i - chemxb + 1))/2.0_wp end do lambda_Cell = 0.5_wp*(lambda_R + lambda_L) @@ -276,11 +280,10 @@ contains do eqn = chemxb, chemxe #:if USING_AMD Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*mass_diffusivities_mixavg_Cell(eqn - chemxb + 1) & - & *molecular_weights_nonparameter(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn & - & - chemxb + 1) + & *molecular_weights_nonparameter(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) #:else Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*mass_diffusivities_mixavg_Cell(eqn - chemxb + 1) & - & *molecular_weights(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) + & *molecular_weights(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) #:endif rho_Vic = rho_Vic + Mass_Diffu_Flux(eqn - chemxb + 1) Mass_Diffu_Energy = Mass_Diffu_Energy + h_k(eqn - chemxb + 1)*Mass_Diffu_Flux(eqn - chemxb + 1) @@ -291,7 +294,7 @@ contains do eqn = chemxb, chemxe Mass_Diffu_Energy = Mass_Diffu_Energy - h_k(eqn - chemxb + 1)*Ys_cell(eqn - chemxb + 1)*rho_Vic Mass_Diffu_Flux(eqn - chemxb + 1) = Mass_Diffu_Flux(eqn - chemxb + 1) - rho_Vic*Ys_cell(eqn & - & - chemxb + 1) + & - chemxb + 1) end do ! Add thermal conduction contribution diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index 4c3d65a2fe..02598b8237 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -21,6 +21,7 @@ impure subroutine s_create_directory(dir_name) call system('mkdir -p "' // dir_name // '"') #endif end subroutine s_create_directory + !> @brief Deletes a file at the given path using a platform-specific system command. impure subroutine s_delete_file(filepath) character(LEN=*), intent(in) :: filepath @@ -31,6 +32,7 @@ impure subroutine s_delete_file(filepath) call system('rm "' // filepath // '"') #endif end subroutine s_delete_file + !> @brief Recursively deletes a directory using a platform-specific system command. impure subroutine s_delete_directory(dir_name) character(LEN=*), intent(in) :: dir_name @@ -41,6 +43,7 @@ impure subroutine s_delete_directory(dir_name) call system('rm -r "' // dir_name // '"') #endif end subroutine s_delete_directory + !> Inquires on the existence of a directory !! @param fileloc File directory location !! @param dircheck Switch that indicates if directory exists @@ -54,12 +57,14 @@ impure subroutine my_inquire(fileloc, dircheck) inquire (FILE=trim(fileloc), EXIST=dircheck) ! GCC #endif end subroutine my_inquire + !> @brief Retrieves the current working directory path via the GETCWD intrinsic. impure subroutine s_get_cwd(cwd) character(LEN=*), intent(out) :: cwd call GETCWD(cwd) end subroutine s_get_cwd + !> @brief Extracts the base filename from a directory path using the system basename command. impure subroutine s_get_basename(dirpath, basename) character(LEN=*), intent(in) :: dirpath diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index f5153347c6..47298914b1 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -6,69 +6,69 @@ module m_constants use m_precision_select - character, parameter :: dflt_char = ' ' !< Default string value - real(wp), parameter :: dflt_real = -1.e6_wp !< Default real value - real(wp), parameter :: sgm_eps = 1.e-16_wp !< Segmentation tolerance - real(wp), parameter :: Chem_Tolerance = 1.e-16_wp !< Speed of Sound Tolerance in Chemistry - real(wp), parameter :: small_alf = 1.e-11_wp !< Small alf tolerance - real(wp), parameter :: pi = 3.141592653589793_wp !< Pi - real(wp), parameter :: verysmall = 1.e-12_wp !< Very small number + character, parameter :: dflt_char = ' ' !< Default string value + real(wp), parameter :: dflt_real = -1.e6_wp !< Default real value + real(wp), parameter :: sgm_eps = 1.e-16_wp !< Segmentation tolerance + real(wp), parameter :: Chem_Tolerance = 1.e-16_wp !< Speed of Sound Tolerance in Chemistry + real(wp), parameter :: small_alf = 1.e-11_wp !< Small alf tolerance + real(wp), parameter :: pi = 3.141592653589793_wp !< Pi + real(wp), parameter :: verysmall = 1.e-12_wp !< Very small number real(wp), & - & parameter :: small_radius = 1.e-32_wp !< Radius cutoff to avoid division by zero for 3D spherical harmonic patch (geometry 14) + & parameter :: small_radius = 1.e-32_wp !< Radius cutoff to avoid division by zero for 3D spherical harmonic patch (geometry 14) - integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils - integer, parameter :: path_len = 400 !< Maximum path length - integer, parameter :: name_len = 50 !< Maximum name length - integer, parameter :: dflt_int = -100 !< Default integer value - integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit - integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation - integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation + integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils + integer, parameter :: path_len = 400 !< Maximum path length + integer, parameter :: name_len = 50 !< Maximum name length + integer, parameter :: dflt_int = -100 !< Default integer value + integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit + integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation + integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation integer, parameter :: num_patches_max = 1000 integer, parameter :: num_bc_patches_max = 10 - integer, parameter :: max_2d_fourier_modes = 10 !< Max Fourier mode index for 2D modal patch (geometry 13) - integer, parameter :: max_sph_harm_degree = 5 !< Max degree L for 3D spherical harmonic patch (geometry 14) + integer, parameter :: max_2d_fourier_modes = 10 !< Max Fourier mode index for 2D modal patch (geometry 13) + integer, parameter :: max_sph_harm_degree = 5 !< Max degree L for 3D spherical harmonic patch (geometry 14) integer, parameter :: pathlen_max = 400 - integer, parameter :: nnode = 4 !< Number of QBMM nodes - integer, parameter :: dflt_num_igr_iters = 2 !< number of iterations for IGR elliptic solve + integer, parameter :: nnode = 4 !< Number of QBMM nodes + integer, parameter :: dflt_num_igr_iters = 2 !< number of iterations for IGR elliptic solve integer, parameter :: dflt_num_igr_warm_start_iters = 50 !< default number of iterations for IGR elliptic solve - real(wp), parameter :: dflt_alf_factor = 10._wp !< scaling factor for IGR alpha - integer, parameter :: gp_layers = 3 !< Number of ghost point layers for IBM + real(wp), parameter :: dflt_alf_factor = 10._wp !< scaling factor for IGR alpha + integer, parameter :: gp_layers = 3 !< Number of ghost point layers for IBM real(wp), & - & parameter :: capillary_cutoff = 1.e-6 !< color function gradient magnitude at which to apply the surface tension fluxes + & parameter :: capillary_cutoff = 1.e-6 !< color function gradient magnitude at which to apply the surface tension fluxes real(wp), & - & parameter :: acoustic_spatial_support_width = 2.5_wp !< Spatial support width of acoustic source, used in s_source_spatial + & parameter :: acoustic_spatial_support_width = 2.5_wp !< Spatial support width of acoustic source, used in s_source_spatial real(wp), parameter :: dflt_vcfl_dt = 100._wp !< value of vcfl_dt when viscosity is off for computing adaptive timestep size real(wp), & - & parameter :: broadband_spectral_level_constant = 20._wp !< The constant to scale the spectral level at the lower frequency bound + & parameter :: broadband_spectral_level_constant = 20._wp !< The constant to scale the spectral level at the lower frequency bound real(wp), & - & parameter :: broadband_spectral_level_growth_rate = 10._wp !< The spectral level constant to correct the magnitude at each frequency to ensure the source is overall broadband + & parameter :: broadband_spectral_level_growth_rate = 10._wp !< The spectral level constant to correct the magnitude at each frequency to ensure the source is overall broadband ! Reconstruction Types - integer, parameter :: WENO_TYPE = 1 !< Using WENO for reconstruction type + integer, parameter :: WENO_TYPE = 1 !< Using WENO for reconstruction type integer, parameter :: MUSCL_TYPE = 2 !< Using MUSCL for reconstruction type ! Interface Compression - real(wp), parameter :: dflt_ic_eps = 1e-4_wp !< Ensure compression is only applied to surface cells in THINC - real(wp), parameter :: dflt_ic_beta = 1.6_wp !< Sharpness parameter's default value used in THINC + real(wp), parameter :: dflt_ic_eps = 1e-4_wp !< Ensure compression is only applied to surface cells in THINC + real(wp), parameter :: dflt_ic_beta = 1.6_wp !< Sharpness parameter's default value used in THINC real(wp), parameter :: moncon_cutoff = 1e-8_wp !< Monotonicity constraint's limiter to prevent extremas in THINC ! Chemistry real(wp), parameter :: dflt_T_guess = 1200._wp ! Default guess for temperature (when a previous value is not available) ! IBM+STL interpolation constants - integer, parameter :: num_ray = 20 !< Default number of rays traced per cell - real(wp), parameter :: ray_tracing_threshold = 0.9_wp !< Threshold above which the cell is marked as the model patch - real(wp), parameter :: threshold_vector_zero = 1.e-10_wp !< Threshold to treat the component of a vector to be zero - real(wp), parameter :: threshold_edge_zero = 1.e-10_wp !< Threshold to treat two edges to be overlapped + integer, parameter :: num_ray = 20 !< Default number of rays traced per cell + real(wp), parameter :: ray_tracing_threshold = 0.9_wp !< Threshold above which the cell is marked as the model patch + real(wp), parameter :: threshold_vector_zero = 1.e-10_wp !< Threshold to treat the component of a vector to be zero + real(wp), parameter :: threshold_edge_zero = 1.e-10_wp !< Threshold to treat two edges to be overlapped real(wp), parameter :: initial_distance_buffer = 1.e12_wp !< Initialized levelset distance for the shortest path pair algorithm ! Lagrange bubbles constants - integer, parameter :: mapCells = 3 !< Number of cells around the bubble where the smoothening function will have effect - real(wp), parameter :: R_uni = 8314._wp !< Universal gas constant - J/kmol/K + integer, parameter :: mapCells = 3 !< Number of cells around the bubble where the smoothening function will have effect + real(wp), parameter :: R_uni = 8314._wp !< Universal gas constant - J/kmol/K integer, parameter :: lag_io_vars = 21 ! Number of variables per particle for MPI_IO ! Strang Splitting constants - real(wp), parameter :: dflt_adap_dt_tol = 1.e-4_wp !< Default tolerance for adaptive step size + real(wp), parameter :: dflt_adap_dt_tol = 1.e-4_wp !< Default tolerance for adaptive step size integer, parameter :: dflt_adap_dt_max_iters = 100 !< Default max iteration for adaptive step size ! Constants of the algorithm described by Heirer, E. Hairer, S. P.Norsett, G. Wanner, Solving Ordinary Differential Equations I, diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 43a33202c0..5870f87c1f 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -7,7 +7,6 @@ !> @brief Shared derived types for field data, patch geometry, bubble dynamics, and MPI I/O structures module m_derived_types use m_constants !< Constants - use m_precision_select use m_thermochem, only: num_species @@ -132,7 +131,7 @@ module m_derived_types integer, dimension(:), allocatable :: vs integer, dimension(:), allocatable :: ps integer, dimension(:), allocatable :: ms - integer, dimension(:,:), allocatable :: moms !< Moment indices for qbmm + integer, dimension(:,:), allocatable :: moms !< Moment indices for qbmm integer, dimension(:,:,:), allocatable :: fullmom !< Moment indices for qbmm end type bub_bounds_info @@ -198,14 +197,14 @@ module m_derived_types !! patch geometry. type ic_patch_parameters - integer :: geometry !< Type of geometry for the patch + integer :: geometry !< Type of geometry for the patch real(wp) :: x_centroid, y_centroid, z_centroid !< !! Location of the geometric center, i.e. the centroid, of the patch. It !! is specified through its x-, y- and z-coordinates, respectively. real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. - real(wp), dimension(3) :: radii !< + real(wp) :: radius !< Dimensions of the patch. radius. + real(wp), dimension(3) :: radii !< !! Vector indicating the various radii for the elliptical and ellipsoidal !! patch geometries. It is specified through its x-, y-, and z-components !! respectively. @@ -222,8 +221,8 @@ module m_derived_types ! Geometry 13 (2D modal Fourier): fourier_cos(n), fourier_sin(n) for mode n real(wp), dimension(1:max_2d_fourier_modes) :: fourier_cos, fourier_sin logical :: modal_clip_r_to_min !< When true, clip boundary radius: R(theta) = max(R(theta), modal_r_min) (Non-exp form only) - real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) - logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) + real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) + logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) ! Geometry 14 (3D spherical harmonic): sph_har_coeff(l,m) for real Y_lm real(wp), dimension(0:max_sph_harm_degree, -max_sph_harm_degree:max_sph_harm_degree) :: sph_har_coeff @@ -255,9 +254,9 @@ module m_derived_types real(wp), dimension(num_fluids_max) :: alpha real(wp) :: gamma real(wp) :: pi_inf !< - real(wp) :: cv !< - real(wp) :: qv !< - real(wp) :: qvp !< + real(wp) :: cv !< + real(wp) :: qv !< + real(wp) :: qvp !< !! Primitive variables associated with the patch. In order, these include !! the partial densities, density, velocity, pressure, volume fractions, @@ -301,7 +300,7 @@ module m_derived_types type ib_patch_parameters - integer :: geometry !< Type of geometry for the patch + integer :: geometry !< Type of geometry for the patch real(wp) :: x_centroid, y_centroid, z_centroid !< !! Location of the geometric center, i.e. the centroid, of the patch. It !! is specified through its x-, y- and z-coordinates, respectively. @@ -312,11 +311,11 @@ module m_derived_types real(wp), dimension(1:3) :: step_angles real(wp), dimension(1:3, 1:3) :: rotation_matrix !< matrix that converts from IB reference frame to fluid reference frame real(wp), dimension(1:3, & - & 1:3) :: rotation_matrix_inverse !< matrix that converts from fluid reference frame to IB reference frame + & 1:3) :: rotation_matrix_inverse !< matrix that converts from fluid reference frame to IB reference frame real(wp) :: c, p, t, m real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. + real(wp) :: radius !< Dimensions of the patch. radius. real(wp) :: theta logical :: slip @@ -353,37 +352,37 @@ module m_derived_types !> Derived type annexing the physical parameters (PP) of the fluids. These include the specific heat ratio function and liquid !! stiffness function. type physical_parameters - real(wp) :: gamma !< Sp. heat ratio - real(wp) :: pi_inf !< Liquid stiffness - real(wp), dimension(2) :: Re !< Reynolds number - real(wp) :: cv !< heat capacity - real(wp) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) - real(wp) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) + real(wp) :: gamma !< Sp. heat ratio + real(wp) :: pi_inf !< Liquid stiffness + real(wp), dimension(2) :: Re !< Reynolds number + real(wp) :: cv !< heat capacity + real(wp) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) + real(wp) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) real(wp) :: G end type physical_parameters !> Derived type annexing the physical parameters required for sub-grid bubble models type subgrid_bubble_physical_parameters - real(wp) :: R0ref !< reference bubble radius - real(wp) :: p0ref !< reference pressure + real(wp) :: R0ref !< reference bubble radius + real(wp) :: p0ref !< reference pressure real(wp) :: rho0ref !< reference density - real(wp) :: T0ref !< reference temperature - real(wp) :: ss !< surface tension between host and gas (bubble) - real(wp) :: pv !< vapor pressure of host - real(wp) :: vd !< vapor diffusivity in gas (bubble) - real(wp) :: mu_l !< viscosity of host in liquid state - real(wp) :: mu_v !< viscosity of host in vapor state - real(wp) :: mu_g !< viscosity of gas (bubble) - real(wp) :: gam_v !< specific heat ratio of host in vapor state - real(wp) :: gam_g !< specific heat ratio of gas (bubble) - real(wp) :: M_v !< Molecular weight of host - real(wp) :: M_g !< Molecular weight of gas (bubble) - real(wp) :: k_v !< thermal conductivity of host in vapor state - real(wp) :: k_g !< thermal conductivity of gas (bubble) - real(wp) :: cp_v !< specific heat capacity in constant pressure of host in vapor state - real(wp) :: cp_g !< specific heat capacity in constant pressure of gas (bubble) - real(wp) :: R_v !< gas constant of host in vapor state - real(wp) :: R_g !< gas constant of gas (bubble) + real(wp) :: T0ref !< reference temperature + real(wp) :: ss !< surface tension between host and gas (bubble) + real(wp) :: pv !< vapor pressure of host + real(wp) :: vd !< vapor diffusivity in gas (bubble) + real(wp) :: mu_l !< viscosity of host in liquid state + real(wp) :: mu_v !< viscosity of host in vapor state + real(wp) :: mu_g !< viscosity of gas (bubble) + real(wp) :: gam_v !< specific heat ratio of host in vapor state + real(wp) :: gam_g !< specific heat ratio of gas (bubble) + real(wp) :: M_v !< Molecular weight of host + real(wp) :: M_g !< Molecular weight of gas (bubble) + real(wp) :: k_v !< thermal conductivity of host in vapor state + real(wp) :: k_g !< thermal conductivity of gas (bubble) + real(wp) :: cp_v !< specific heat capacity in constant pressure of host in vapor state + real(wp) :: cp_g !< specific heat capacity in constant pressure of gas (bubble) + real(wp) :: R_v !< gas constant of host in vapor state + real(wp) :: R_g !< gas constant of gas (bubble) end type subgrid_bubble_physical_parameters type mpi_io_airfoil_ib_var @@ -403,31 +402,31 @@ module m_derived_types !> Acoustic source parameters type acoustic_parameters - integer :: pulse !< Type of pulse - integer :: support !< Type of support - logical :: dipole !< Whether the source is a dipole or monopole - real(wp), dimension(3) :: loc !< Physical location of acoustic source - real(wp) :: mag !< Acoustic pulse magnitude - real(wp) :: length !< Length of planar source (2D/3D) - real(wp) :: height !< Height of planar source (3D) - real(wp) :: wavelength !< Wave length of pulse - real(wp) :: frequency !< Frequency of pulse - real(wp) :: gauss_sigma_dist !< sigma of Gaussian pulse multiplied by speed of sound - real(wp) :: gauss_sigma_time !< sigma of Gaussian pulse - real(wp) :: npulse !< Number of cycles of pulse - real(wp) :: dir !< Direction of pulse - real(wp) :: delay !< Time-delay of pulse start + integer :: pulse !< Type of pulse + integer :: support !< Type of support + logical :: dipole !< Whether the source is a dipole or monopole + real(wp), dimension(3) :: loc !< Physical location of acoustic source + real(wp) :: mag !< Acoustic pulse magnitude + real(wp) :: length !< Length of planar source (2D/3D) + real(wp) :: height !< Height of planar source (3D) + real(wp) :: wavelength !< Wave length of pulse + real(wp) :: frequency !< Frequency of pulse + real(wp) :: gauss_sigma_dist !< sigma of Gaussian pulse multiplied by speed of sound + real(wp) :: gauss_sigma_time !< sigma of Gaussian pulse + real(wp) :: npulse !< Number of cycles of pulse + real(wp) :: dir !< Direction of pulse + real(wp) :: delay !< Time-delay of pulse start real(wp) :: foc_length ! < Focal length of transducer real(wp) :: aperture ! < Aperture diameter of transducer real(wp) :: element_spacing_angle !< Spacing between aperture elements in 2D acoustic array real(wp) & - & :: element_polygon_ratio !< Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array - real(wp) :: rotate_angle !< Angle of rotation of the entire circular 3D acoustic array - real(wp) :: bb_bandwidth !< Bandwidth of each frequency in broadband wave + & :: element_polygon_ratio !< Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array + real(wp) :: rotate_angle !< Angle of rotation of the entire circular 3D acoustic array + real(wp) :: bb_bandwidth !< Bandwidth of each frequency in broadband wave real(wp) :: bb_lowest_freq !< The lower frequency bound of broadband wave - integer :: num_elements !< Number of elements in the acoustic array - integer :: element_on !< Element in the acoustic array to turn on - integer :: bb_num_freq !< Number of frequencies in the broadband wave + integer :: num_elements !< Number of elements in the acoustic array + integer :: element_on !< Element in the acoustic array to turn on + integer :: bb_num_freq !< Number of frequencies in the broadband wave end type acoustic_parameters !> Acoustic source source_spatial pre-calculated values @@ -440,11 +439,11 @@ module m_derived_types !> Ghost Point for Immersed Boundaries type ghost_point - integer, dimension(3) :: loc !< Physical location of the ghost point - real(wp), dimension(3) :: ip_loc !< Physical location of the image point - integer, dimension(3) :: ip_grid !< Top left grid point of IP + integer, dimension(3) :: loc !< Physical location of the ghost point + real(wp), dimension(3) :: ip_loc !< Physical location of the image point + integer, dimension(3) :: ip_grid !< Top left grid point of IP real(wp), dimension(2, 2, 2) :: interp_coeffs !< Interpolation Coefficients of image point - integer :: ib_patch_id !< ID of the IB Patch the ghost point is part of + integer :: ib_patch_id !< ID of the IB Patch the ghost point is part of real(wp) :: levelset real(wp), dimension(1:3) :: levelset_norm logical :: slip @@ -473,18 +472,18 @@ module m_derived_types !> Lagrangian bubble parameters type bubbles_lagrange_parameters - integer :: solver_approach !< 1: One-way coupling, 2: two-way coupling - integer :: cluster_type !< Cluster model to find p_inf - logical :: pressure_corrector !< Cell pressure correction term - integer :: smooth_type !< Smoothing function. 1: Gaussian, 2:Delta 3x3 - logical :: heatTransfer_model !< Activate HEAT transfer model at the bubble-liquid interface - logical :: massTransfer_model !< Activate MASS transfer model at the bubble-liquid interface - logical :: write_bubbles !< Write files to track the bubble evolution each time step - logical :: write_bubbles_stats !< Write the maximum and minimum radius of each bubble - integer :: nBubs_glb !< Global number of bubbles - real(wp) :: epsilonb !< Standard deviation scaling for the gaussian function - real(wp) :: charwidth !< Domain virtual depth (z direction, for 2D simulations) - real(wp) :: valmaxvoid !< Maximum void fraction permitted + integer :: solver_approach !< 1: One-way coupling, 2: two-way coupling + integer :: cluster_type !< Cluster model to find p_inf + logical :: pressure_corrector !< Cell pressure correction term + integer :: smooth_type !< Smoothing function. 1: Gaussian, 2:Delta 3x3 + logical :: heatTransfer_model !< Activate HEAT transfer model at the bubble-liquid interface + logical :: massTransfer_model !< Activate MASS transfer model at the bubble-liquid interface + logical :: write_bubbles !< Write files to track the bubble evolution each time step + logical :: write_bubbles_stats !< Write the maximum and minimum radius of each bubble + integer :: nBubs_glb !< Global number of bubbles + real(wp) :: epsilonb !< Standard deviation scaling for the gaussian function + real(wp) :: charwidth !< Domain virtual depth (z direction, for 2D simulations) + real(wp) :: valmaxvoid !< Maximum void fraction permitted end type bubbles_lagrange_parameters !> Max and min number of cells in a direction of each combination of x-,y-, and z- diff --git a/src/common/m_finite_differences.fpp b/src/common/m_finite_differences.fpp index eafd4fee1f..651691ce9e 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -24,10 +24,10 @@ contains do z = iz_s%beg, iz_s%end if (x == ix_s%beg) then divergence = (-3._wp*fields(1)%sf(x, y, z) + 4._wp*fields(1)%sf(x + 1, y, z) - fields(1)%sf(x + 2, y, & - & z))/(x_cc(x + 2) - x_cc(x)) + & z))/(x_cc(x + 2) - x_cc(x)) else if (x == ix_s%end) then divergence = (+3._wp*fields(1)%sf(x, y, z) - 4._wp*fields(1)%sf(x - 1, y, z) + fields(1)%sf(x - 2, y, & - & z))/(x_cc(x) - x_cc(x - 2)) + & z))/(x_cc(x) - x_cc(x - 2)) else divergence = (fields(1)%sf(x + 1, y, z) - fields(1)%sf(x - 1, y, z))/(x_cc(x + 1) - x_cc(x - 1)) end if @@ -35,26 +35,26 @@ contains if (n > 0) then if (y == iy_s%beg) then divergence = divergence + (-3._wp*fields(2)%sf(x, y, z) + 4._wp*fields(2)%sf(x, y + 1, & - & z) - fields(2)%sf(x, y + 2, z))/(y_cc(y + 2) - y_cc(y)) + & z) - fields(2)%sf(x, y + 2, z))/(y_cc(y + 2) - y_cc(y)) else if (y == iy_s%end) then divergence = divergence + (+3._wp*fields(2)%sf(x, y, z) - 4._wp*fields(2)%sf(x, y - 1, & - & z) + fields(2)%sf(x, y - 2, z))/(y_cc(y) - y_cc(y - 2)) + & z) + fields(2)%sf(x, y - 2, z))/(y_cc(y) - y_cc(y - 2)) else divergence = divergence + (fields(2)%sf(x, y + 1, z) - fields(2)%sf(x, y - 1, & - & z))/(y_cc(y + 1) - y_cc(y - 1)) + & z))/(y_cc(y + 1) - y_cc(y - 1)) end if end if if (p > 0) then if (z == iz_s%beg) then divergence = divergence + (-3._wp*fields(3)%sf(x, y, z) + 4._wp*fields(3)%sf(x, y, & - & z + 1) - fields(3)%sf(x, y, z + 2))/(z_cc(z + 2) - z_cc(z)) + & z + 1) - fields(3)%sf(x, y, z + 2))/(z_cc(z + 2) - z_cc(z)) else if (z == iz_s%end) then divergence = divergence + (+3._wp*fields(3)%sf(x, y, z) - 4._wp*fields(3)%sf(x, y, & - & z - 1) + fields(3)%sf(x, y, z - 2))/(z_cc(z) - z_cc(z - 2)) + & z - 1) + fields(3)%sf(x, y, z - 2))/(z_cc(z) - z_cc(z - 2)) else divergence = divergence + (fields(3)%sf(x, y, z + 1) - fields(3)%sf(x, y, & - & z - 1))/(z_cc(z + 1) - z_cc(z - 1)) + & z - 1))/(z_cc(z + 1) - z_cc(z - 1)) end if end if @@ -64,6 +64,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_compute_fd_divergence + !> The purpose of this subroutine is to compute the finite- difference coefficients for the centered schemes utilized in !! computations of first order spatial derivatives in the s-coordinate direction. The s-coordinate direction refers to the x-, !! y- or z-coordinate direction, depending on the subroutine's inputs. Note that coefficients of up to 4th order accuracy are @@ -82,7 +83,7 @@ contains type(int_bounds_info), optional, intent(in) :: offset_s real(wp), allocatable, dimension(:,:), intent(inout) :: fd_coeff_s real(wp), dimension(-local_buff_size:q + local_buff_size), intent(in) :: s_cc - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator if (present(offset_s)) then lB = -offset_s%beg diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index cb8ccaceb3..0c8b99ceb7 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -8,9 +8,7 @@ !> @brief Utility routines for bubble model setup, coordinate transforms, array sampling, and special functions module m_helper use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use ieee_arithmetic !< For checking NaN implicit none @@ -38,6 +36,7 @@ contains R3 = dot_product(weights, Rtmp**3._wp) ntmp = (3._wp/(4._wp*pi))*vftmp/R3 end subroutine s_comp_n_from_prim + !> @brief Computes the bubble number density from the conservative void fraction and weighted bubble radii. subroutine s_comp_n_from_cons(vftmp, nRtmp, ntmp, weights) $:GPU_ROUTINE(parallelism='[seq]') @@ -50,6 +49,7 @@ contains nR3 = dot_product(weights, nRtmp**3._wp) ntmp = sqrt((4._wp*pi/3._wp)*nR3/vftmp) end subroutine s_comp_n_from_cons + !> @brief Prints a 2D real array to standard output, optionally dividing each element by a given scalar. impure subroutine s_print_2D_array(A, div) real(wp), dimension(:,:), intent(in) :: A @@ -77,6 +77,7 @@ contains end do write (*, fmt="(A1)") " " end subroutine s_print_2D_array + !> bubbles_euler + polytropic bubbles_euler + non-polytropic bubbles_lagrange + non-polytropic impure subroutine s_initialize_bubbles_model() ! Allocate memory @@ -104,6 +105,7 @@ contains ! Initialize bubble variables call s_initialize_bubble_vars() end subroutine s_initialize_bubbles_model + !> impure subroutine s_initialize_bubble_vars() R0ref = bub_pp%R0ref; p0ref = bub_pp%p0ref @@ -154,6 +156,7 @@ contains end if end if end subroutine s_initialize_bubble_vars + !> Initializes non-polydisperse bubble modeling impure subroutine s_initialize_nonpoly() integer :: ir @@ -200,6 +203,7 @@ contains end do Im_trans_T = 0._wp end subroutine s_initialize_nonpoly + !> Computes the transfer coefficient for the non-polytropic bubble compression process !! @param omega natural frequencies !! @param peclet Peclet number @@ -220,6 +224,7 @@ contains Re_trans = trans Im_trans = aimag(trans) end subroutine s_transcoeff + !> @brief Converts an integer to its trimmed string representation. elemental subroutine s_int_to_str(i, res) integer, intent(in) :: i @@ -228,6 +233,7 @@ contains write (res, '(I0)') i res = trim(res) end subroutine s_int_to_str + !> Computes the Simpson weights for quadrature subroutine s_simpson(local_weight, local_R0) real(wp), dimension(:), intent(inout) :: local_weight @@ -265,6 +271,7 @@ contains tmp = exp(-0.5_wp*(phi(nb)/sd)**2)/sqrt(2._wp*pi)/sd local_weight(nb) = tmp*dphi/3._wp end subroutine s_simpson + !> This procedure computes the cross product of two vectors. !! @param a First vector. !! @param b Second vector. @@ -279,6 +286,7 @@ contains c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) end function f_cross + !> This procedure swaps two real numbers. !! @param lhs Left-hand side. !! @param rhs Right-hand side. @@ -290,6 +298,7 @@ contains lhs = rhs rhs = ltemp end subroutine s_swap + !> This procedure creates a transformation matrix. !! @param param Parameters for the transformation. !! @param center Optional center point for the transformation. @@ -300,34 +309,35 @@ contains real(wp), dimension(1:4, 1:4) :: sc, rz, rx, ry, tr, t_back, t_to_origin, out_matrix sc = transpose(reshape([param%scale(1), 0._wp, 0._wp, 0._wp, 0._wp, param%scale(2), 0._wp, 0._wp, 0._wp, 0._wp, & - & param%scale(3), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(sc))) + & param%scale(3), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(sc))) rz = transpose(reshape([cos(param%rotate(3)), -sin(param%rotate(3)), 0._wp, 0._wp, sin(param%rotate(3)), & - & cos(param%rotate(3)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp, 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rz))) + & cos(param%rotate(3)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp, 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rz))) rx = transpose(reshape([1._wp, 0._wp, 0._wp, 0._wp, 0._wp, cos(param%rotate(1)), -sin(param%rotate(1)), 0._wp, 0._wp, & - & sin(param%rotate(1)), cos(param%rotate(1)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rx))) + & sin(param%rotate(1)), cos(param%rotate(1)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rx))) ry = transpose(reshape([cos(param%rotate(2)), 0._wp, sin(param%rotate(2)), 0._wp, 0._wp, 1._wp, 0._wp, 0._wp, & - & -sin(param%rotate(2)), 0._wp, cos(param%rotate(2)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(ry))) + & -sin(param%rotate(2)), 0._wp, cos(param%rotate(2)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(ry))) tr = transpose(reshape([1._wp, 0._wp, 0._wp, param%translate(1), 0._wp, 1._wp, 0._wp, param%translate(2), 0._wp, 0._wp, & - & 1._wp, param%translate(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + & 1._wp, param%translate(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) if (present(center)) then ! Translation matrix to move center to the origin t_to_origin = transpose(reshape([1._wp, 0._wp, 0._wp, -center(1), 0._wp, 1._wp, 0._wp, -center(2), 0._wp, 0._wp, & - & 1._wp, -center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + & 1._wp, -center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) ! Translation matrix to move center back to original position t_back = transpose(reshape([1._wp, 0._wp, 0._wp, center(1), 0._wp, 1._wp, 0._wp, center(2), 0._wp, 0._wp, 1._wp, & - & center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + & center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) out_matrix = matmul(tr, matmul(t_back, matmul(ry, matmul(rx, matmul(rz, matmul(sc, t_to_origin)))))) else out_matrix = matmul(ry, matmul(rx, rz)) end if end function f_create_transform_matrix + !> This procedure transforms a vector by a matrix. !! @param vec Vector to transform. !! @param matrix Transformation matrix. @@ -339,6 +349,7 @@ contains tmp = matmul(matrix, [vec(1), vec(2), vec(3), 1._wp]) vec = tmp(1:3) end subroutine s_transform_vec + !> This procedure transforms a triangle by a matrix, one vertex at a time. !! @param triangle Triangle to transform. !! @param matrix Transformation matrix. @@ -354,6 +365,7 @@ contains call s_transform_vec(triangle%n(1:3), matrix_n) end subroutine s_transform_triangle + !> This procedure transforms a model by a matrix, one triangle at a time. !! @param model Model to transform. !! @param matrix Transformation matrix. @@ -367,6 +379,7 @@ contains call s_transform_triangle(model%trs(i), matrix, matrix_n) end do end subroutine s_transform_model + !> This procedure creates a bounding box for a model. !! @param model Model to create bounding box for. !! @return Bounding box. @@ -391,6 +404,7 @@ contains end do end do end function f_create_bbox + !> This procedure performs xor on lhs and rhs. !! @param lhs logical input. !! @param rhs other logical input. @@ -401,6 +415,7 @@ contains res = (lhs .and. .not. rhs) .or. (.not. lhs .and. rhs) end function f_xor + !> This procedure converts logical to 1 or 0. !! @param predicate A Logical argument. !! @return 1 if .true., 0 if .false.. @@ -414,6 +429,7 @@ contains int = 0 end if end function f_logical_to_int + !> Real spherical harmonic Y_lm(theta, phi). theta = polar angle from +z (acos(z/r)), phi = atan2(y,x). Uses associated Legendre !! P_l^|m|(cos theta). Standard normalisation. function real_ylm(theta, phi, l, m) result(Y) @@ -437,6 +453,7 @@ contains Y = prefac*sqrt(2._wp)*associated_legendre(x, l, m_abs)*sin(m_abs*phi) end if end function real_ylm + !> Associated Legendre polynomial P_l^m(x) (Ferrers function, Condon-Shortley phase). Valid for integer l >= 0, 0 <= m <= l, and !! x in [-1,1]. Returns 0 for |m| > l or l < 0. Formulas: DLMF 14.10.3 (recurrence in degree), Wikipedia "Associated Legendre !! polynomials" (P_l^l and P_l^{l-1} identities). Recurrence: (l-m)P_l^m = (2l-1)x P_{l-1}^m - (l+m-1)P_{l-2}^m. @@ -471,9 +488,10 @@ contains result_P = x*(2*l - 1)*associated_legendre(x, l - 1, l - 1) else result_P = ((2*l - 1)*x*associated_legendre(x, l - 1, m_order) - (l + m_order - 1)*associated_legendre(x, l - 2, & - & m_order))/(l - m_order) + & m_order))/(l - m_order) end if end function associated_legendre + !> This function calculates the double factorial value of an integer !! @param n_in is the input integer !! @return R is the double factorial value of n @@ -485,6 +503,7 @@ contains R_result = product((/(i, i=n_in, 1, -2)/)) end function double_factorial + !> The following function calculates the factorial value of an integer !! @param n_in is the input integer !! @return R is the factorial value of n @@ -496,6 +515,7 @@ contains R_result = product((/(i, i=n_in, 1, -1)/)) end function factorial + !> This function calculates a smooth cut-on function that is zero for x values smaller than zero and goes to one. It can be used !! for generating smooth initial conditions !! @param x is the input value @@ -507,6 +527,7 @@ contains fx = 1 - f_gx(x/eps)/(f_gx(x/eps) + f_gx(1 - x/eps)) end function f_cut_on + !> This function calculates a smooth cut-off function that is one for x values smaller than zero and goes to zero. It can be !! used for generating smooth initial conditions !! @param x is the input value @@ -518,6 +539,7 @@ contains fx = f_gx(x/eps)/(f_gx(x/eps) + f_gx(1 - x/eps)) end function f_cut_off + !> This function is a helper function for the functions f_cut_on and f_cut_off !! @param x is the input value !! @return gx is the result @@ -531,6 +553,7 @@ contains gx = 0._wp end if end function f_gx + !> @brief Downsamples conservative variable fields by a factor of 3 in each direction using volume averaging. subroutine s_downsample_data(q_cons_vf, q_cons_temp, m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_cons_temp @@ -561,7 +584,7 @@ contains do iy = -1, 1 do ix = -1, 1 q_cons_temp(i)%sf(j, k, l) = q_cons_temp(i)%sf(j, k, & - & l) + (1._wp/27._wp)*q_cons_vf(i)%sf(x_id + ix, y_id + iy, z_id + iz) + & l) + (1._wp/27._wp)*q_cons_vf(i)%sf(x_id + ix, y_id + iy, z_id + iz) end do end do end do @@ -570,6 +593,7 @@ contains end do end do end subroutine s_downsample_data + !> @brief Upsamples conservative variable fields from a coarsened grid back to the original resolution using interpolation. subroutine s_upsample_data(q_cons_vf, q_cons_temp) type(scalar_field), intent(inout), dimension(sys_size) :: q_cons_vf, q_cons_temp @@ -592,13 +616,13 @@ contains temp(1) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy, iz) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy, iz) temp(2) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy + y_id, iz) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, & - & iy + y_id, iz) + & iy + y_id, iz) temp(3) = (2._wp/3._wp)*temp(1) + (1._wp/3._wp)*temp(2) temp(1) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy, iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, & - & iy, iz + z_id) + & iy, iz + z_id) temp(2) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy + y_id, & - & iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy + y_id, iz + z_id) + & iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy + y_id, iz + z_id) temp(4) = (2._wp/3._wp)*temp(1) + (1._wp/3._wp)*temp(2) q_cons_vf(i)%sf(j, k, l) = (2._wp/3._wp)*temp(3) + (1._wp/3._wp)*temp(4) diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 8ddba3d103..79d8fc16bf 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -40,6 +40,7 @@ contains res = (abs(a - b)/min(abs(a) + abs(b), huge(a)) < tol) end if end function f_approx_equal + !> This procedure checks if the point numbers of wp belongs to another array are within tolerance. !! @param a First number. !! @param b Array that contains several point numbers. @@ -68,6 +69,7 @@ contains end if end do end function f_approx_in_array + !> Checks if a real(wp) variable is of default value. !! @param var Variable to check. logical elemental function f_is_default(var) result(res) @@ -76,6 +78,7 @@ contains res = f_approx_equal(var, dflt_real) end function f_is_default + !> Checks if ALL elements of a real(wp) array are of default value. !! @param var_array Array to check. logical function f_all_default(var_array) result(res) @@ -92,6 +95,7 @@ contains ! res = all(res_array) end function f_all_default + !> Checks if a real(wp) variable is an integer. !! @param var Variable to check. logical elemental function f_is_integer(var) result(res) @@ -100,8 +104,9 @@ contains res = f_approx_equal(var, real(nint(var), wp)) end function f_is_integer + subroutine s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & - & bubbles_lagrange, m, n, p, num_dims, igr, ib) + & bubbles_lagrange, m, n, p, num_dims, igr, ib) integer, intent(in) :: recon_type, weno_polyn, muscl_polyn integer, intent(in) :: m, n, p, num_dims, igr_order @@ -148,6 +153,7 @@ contains idwbuff(2)%end = idwint(2)%end - idwbuff(2)%beg idwbuff(3)%end = idwint(3)%end - idwbuff(3)%beg end subroutine s_configure_coordinate_bounds + !> Updates the min and max number of cells in each set of axes !! @param bounds Min ans max values to update !! @param m Number of cells in x-axis diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index 0c24f936af..d0c2dca6a4 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -10,7 +10,6 @@ module m_model use m_helper use m_mpi_proxy use m_derived_types - use iso_c_binding, only: c_char, c_int32_t, c_int16_t, c_float implicit none @@ -84,6 +83,7 @@ contains close (iunit) end subroutine s_read_stl_binary + !> This procedure reads an ASCII STL file. !! @param filepath Path to the STL file. !! @param model the STL file. @@ -191,6 +191,7 @@ contains i = i + 1 end do end subroutine s_read_stl_ascii + !> This procedure reads an STL file. !! @param filepath Path to the STL file. !! @param model the STL file. @@ -218,6 +219,7 @@ contains call s_read_stl_binary(filepath, model) end if end subroutine s_read_stl + !> This procedure reads an OBJ file. !! @param filepath Path to the obj file. !! @param model The obj file. @@ -286,6 +288,7 @@ contains close (iunit) end subroutine s_read_obj + !> This procedure reads a mesh from a file. !! @param filepath Path to the file to read. !! @return The model read from the file. @@ -304,6 +307,7 @@ contains call s_mpi_abort() end select end function f_model_read + !> This procedure writes a binary STL file. !! @param filepath Path to the STL file. !! @param model STL to write @@ -348,6 +352,7 @@ contains close (iunit) end subroutine s_write_stl + !> This procedure writes an OBJ file. !! @param filepath Path to the obj file. !! @param model obj to write. @@ -370,7 +375,7 @@ contains do i = 1, model%ntrs do j = 1, 3 write (iunit, '(A, " ", (f30.20), " ", (f30.20), " ", (f30.20))') "v", model%trs(i)%v(j, 1), model%trs(i)%v(j, & - & 2), model%trs(i)%v(j, 3) + & 2), model%trs(i)%v(j, 3) end do write (iunit, '(A, " ", I0, " ", I0, " ", I0)') "f", i*3 - 2, i*3 - 1, i*3 @@ -378,6 +383,7 @@ contains close (iunit) end subroutine s_write_obj + !> This procedure writes a binary STL file. !! @param filepath Path to the file to write. !! @param model Model to write. @@ -396,12 +402,14 @@ contains call s_mpi_abort() end select end subroutine s_model_write + !> This procedure frees the memory allocated for an STL mesh. subroutine s_model_free(model) type(t_model), intent(inout) :: model deallocate (model%trs) end subroutine s_model_free + impure function f_read_line(iunit, line) result(bIsLine) integer, intent(in) :: iunit character(80), intent(out) :: line @@ -427,6 +435,7 @@ contains exit end do end function f_read_line + !> @brief Reads the next non-comment line from a model file, using a buffered look-ahead mechanism. impure subroutine s_skip_ignored_lines(iunit, buffered_line, is_buffered) integer, intent(in) :: iunit @@ -444,6 +453,7 @@ contains buffered_line = line is_buffered = .true. end subroutine s_skip_ignored_lines + !> This function is used to replace the fortran random number generator because the native generator is not compatible being !! called from GPU routines/functions function f_model_random_number(seed) result(rval) @@ -458,6 +468,7 @@ contains rval = abs(real(seed, wp))/real(huge(seed), wp) end function f_model_random_number + !> This procedure, recursively, finds whether a point is inside an octree. !! @param model Model to search in. !! @param point Point to test. @@ -513,6 +524,7 @@ contains fraction = real(nInOrOut)/real(spc) end function f_model_is_inside + !> This procedure determines if a point is inside a surface using the generalized winding number (Jacobson et al., SIGGRAPH !! 2013). In 3D, sums the solid angle subtended by each triangle (Van Oosterom-Strackee formula). In 2D (p==0), sums the signed !! angle subtended by each boundary edge. Returns ~1.0 inside, ~0.0 outside. Unlike ray casting, this is robust to small @@ -570,10 +582,10 @@ contains ! tan(Omega/2) = numerator / denominator ! numerator = scalar triple product r1 . (r2 x r3) numerator = r1(1)*(r2(2)*r3(3) - r2(3)*r3(2)) + r1(2)*(r2(3)*r3(1) - r2(1)*r3(3)) + r1(3)*(r2(1)*r3(2) - r2(2) & - & *r3(1)) + & *r3(1)) denominator = r1_mag*r2_mag*r3_mag + dot_product(r1, r2)*r3_mag + dot_product(r2, r3)*r1_mag + dot_product(r3, & - & r1)*r2_mag + & r1)*r2_mag fraction = fraction + atan2(numerator, denominator) end do @@ -583,6 +595,7 @@ contains fraction = fraction/(2.0_wp*acos(-1.0_wp)) end if end function f_model_is_inside_flat + !> This procedure checks if a ray intersects a triangle using the Moller-Trumbore algorithm (barycentric coordinates). Unlike !! the previous cross-product sign test, this is vertex winding-order independent. !! @param ray Ray. @@ -623,6 +636,7 @@ contains if (t > 0.0_wp) intersects = 1 end function f_intersects_triangle + !> This procedure checks and labels edges shared by two or more triangles facets of the 2D STL model. !! @param model Model to search in. !! @param boundary_vertex_count Output total boundary vertex count @@ -734,11 +748,12 @@ contains boundary_v(i, 3, 2) = ynormal/v_norm end do end subroutine s_check_boundary + !> This procedure appends the edge end vertices to a temporary buffer. subroutine s_register_edge(temp_boundary_v, edge, edge_index, edge_count) - integer, intent(inout) :: edge_index !< Edge index iterator - integer, intent(inout) :: edge_count !< Total number of edges - real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered + integer, intent(inout) :: edge_index !< Edge index iterator + integer, intent(inout) :: edge_count !< Total number of edges + real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered real(wp), dimension(1:edge_count, 1:2, 1:2), intent(inout) :: temp_boundary_v !< Temporary edge end vertex buffer ! Increment edge index and store the edge @@ -746,6 +761,7 @@ contains temp_boundary_v(edge_index, 1, 1:2) = edge(1, 1:2) temp_boundary_v(edge_index, 2, 1:2) = edge(2, 1:2) end subroutine s_register_edge + !> This procedure determines the levelset distance and normals of 3D models by computing the exact closest point via projection !! onto triangle surfaces. !! @param ntrs Number of triangles for this patch @@ -864,7 +880,7 @@ contains end if else dist_v = sqrt((point(1) - verts(1, mod(j, 3) + 1))**2 + (point(2) - verts(2, mod(j, & - & 3) + 1))**2 + (point(3) - verts(3, mod(j, 3) + 1))**2) + & 3) + 1))**2 + (point(3) - verts(3, mod(j, 3) + 1))**2) if (dist_v < dist_min) then dist_min = dist_v @@ -880,6 +896,7 @@ contains distance = dist_min end subroutine s_distance_normals_3D + !> This procedure determines the levelset distance and normals of 2D models by computing the exact closest point via projection !! onto boundary edges. !! @param boundary_v Flat GPU array of boundary vertices/normals for all patches @@ -952,6 +969,7 @@ contains distance = dist_min end subroutine s_distance_normals_2D + #ifdef MFC_SIMULATION subroutine s_instantiate_STL_models() @@ -1101,7 +1119,7 @@ contains end if if (allocated(models(pid)%boundary_v) .and. p == 0) then gpu_boundary_v(1:size(models(pid)%boundary_v, 1), 1:size(models(pid)%boundary_v, 2), & - & 1:size(models(pid)%boundary_v, 3), pid) = models(pid)%boundary_v + & 1:size(models(pid)%boundary_v, 3), pid) = models(pid)%boundary_v end if end do @@ -1112,6 +1130,7 @@ contains end if end block end subroutine s_instantiate_STL_models + #endif subroutine s_pack_model_for_gpu(ma) diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 261a29bce5..0de48a15b6 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -12,13 +12,9 @@ module m_mpi_common #endif use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_helper - use ieee_arithmetic - use m_nvtx implicit none @@ -62,7 +58,7 @@ contains if (n > 0) then if (p > 0) then halo_size = nint(-1._wp + 1._wp*buff_size*(v_size)*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)*(p + 2*buff_size & - & + 1)/(cells_bounds%mnp_min + 2*buff_size + 1)) + & + 1)/(cells_bounds%mnp_min + 2*buff_size + 1)) else halo_size = -1 + buff_size*(v_size)*(cells_bounds%mn_max + 2*buff_size + 1) end if @@ -81,6 +77,7 @@ contains #endif #endif end subroutine s_initialize_mpi_common_module + !> The subroutine initializes the MPI execution environment and queries both the number of processors which will be available !! for the job and the local processor rank. impure subroutine s_mpi_initialize @@ -108,6 +105,7 @@ contains proc_rank = 0 #endif end subroutine s_mpi_initialize + !! @param q_cons_vf Conservative variables !! @param ib_markers track if a cell is within the immersed boundary !! @param beta Eulerian void fraction from lagrangian bubbles @@ -168,7 +166,7 @@ contains ! Define the view for each variable do i = 1, alt_sys call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do @@ -176,7 +174,7 @@ contains if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do end if @@ -187,12 +185,13 @@ contains MPI_IO_IB_DATA%var%sf => ib_markers%sf(0:m, 0:n, 0:p) call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, MPI_INTEGER, & - & MPI_IO_IB_DATA%view, ierr) + & MPI_IO_IB_DATA%view, ierr) call MPI_TYPE_COMMIT(MPI_IO_IB_DATA%view, ierr) end if #endif #endif end subroutine s_initialize_mpi_data + !! @param q_cons_vf Conservative variables subroutine s_initialize_mpi_data_ds(q_cons_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -233,11 +232,12 @@ contains ! Define the view for each variable do i = 1, sys_size call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_loc, sizes_loc, sf_start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do #endif end subroutine s_initialize_mpi_data_ds + !> @brief Gathers variable-length real vectors from all MPI ranks onto the root process. impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root) integer, intent(in) :: counts ! Array of vector lengths for each process @@ -266,6 +266,7 @@ contains call MPI_GATHERV(my_vector, counts, mpi_p, gathered_vector, recounts, displs, mpi_p, root, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_gather_data + !> @brief Gathers per-rank time step wall-clock times onto rank 0 for performance reporting. impure subroutine mpi_bcast_time_step_values(proc_time, time_avg) real(wp), dimension(0:num_procs - 1), intent(inout) :: proc_time @@ -277,6 +278,7 @@ contains call MPI_GATHER(time_avg, 1, mpi_p, proc_time(0), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif end subroutine mpi_bcast_time_step_values + !> @brief Prints a case file error with the prohibited condition and message, then aborts execution. impure subroutine s_prohibit_abort(condition, message) character(len=*), intent(in) :: condition, message @@ -290,6 +292,7 @@ contains print *, "" call s_mpi_abort(code=CASE_FILE_ERROR_CODE) end subroutine s_prohibit_abort + !> The goal of this subroutine is to determine the global extrema of the stability criteria in the computational domain. This is !! performed by sifting through the local extrema of each stability criterion. Note that each of the local extrema is from a !! single process, within its assigned section of the computational domain. Finally, note that the global extrema values are @@ -301,7 +304,7 @@ contains !! @param vcfl_max_glb Global maximum VCFL stability criterion !! @param Rc_min_glb Global minimum Rc stability criterion impure subroutine s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & - & Rc_min_glb) + & Rc_min_glb) real(wp), intent(in) :: icfl_max_loc real(wp), intent(in) :: vcfl_max_loc @@ -333,6 +336,7 @@ contains #endif #endif end subroutine s_mpi_reduce_stability_criteria_extrema + !> The following subroutine takes the input local variable from all processors and reduces to the sum of all values. The reduced !! variable is recorded back onto the original local variable on each processor. ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the @@ -349,6 +353,7 @@ contains call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_allreduce_sum + !> This subroutine follows the behavior of the s_mpi_allreduce_sum subroutine !> with the additional feature that it reduces an array of vectors. impure subroutine s_mpi_allreduce_vectors_sum(var_loc, var_glb, num_vectors, vector_length) @@ -369,6 +374,7 @@ contains var_glb(1:num_vectors, 1:vector_length) = var_loc(1:num_vectors, 1:vector_length) #endif end subroutine s_mpi_allreduce_vectors_sum + !> The following subroutine takes the input local variable from all processors and reduces to the sum of all values. The reduced !! variable is recorded back onto the original local variable on each processor. ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the @@ -387,6 +393,7 @@ contains var_glb = var_loc #endif end subroutine s_mpi_allreduce_integer_sum + !> The following subroutine takes the input local variable from all processors and reduces to the minimum of all values. The !! reduced variable is recorded back onto the original local variable on each processor. ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the @@ -403,6 +410,7 @@ contains call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_allreduce_min + !> The following subroutine takes the input local variable from all processors and reduces to the maximum of all values. The !! reduced variable is recorded back onto the original local variable on each processor. ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the @@ -419,6 +427,7 @@ contains call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MAX, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_allreduce_max + !> The following subroutine takes the inputted variable and determines its minimum value on the entire computational domain. The !! result is stored back into inputted variable. ! ! @param var_loc holds the local value to be reduced among all the processors in communicator. On output, the variable holds @@ -441,6 +450,7 @@ contains var_loc = var_glb #endif end subroutine s_mpi_reduce_min + !> The following subroutine takes the first element of the 2-element inputted variable and determines its maximum value on the !! entire computational domain. The result is stored back into the first element of the variable while the rank of the processor !! that is in charge of the sub- domain containing the maximum is stored into the second element of the variable. @@ -451,8 +461,8 @@ contains real(wp), dimension(2), intent(inout) :: var_loc #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors - real(wp), dimension(2) :: var_glb !< + integer :: ierr !< Generic flag used to identify and report MPI errors + real(wp), dimension(2) :: var_glb !< !! Temporary storage variable that holds the reduced maximum value !! and the rank of the processor with which the value is associated @@ -465,6 +475,7 @@ contains var_loc = var_glb #endif end subroutine s_mpi_reduce_maxloc + !> The subroutine terminates the MPI execution environment. !! @param prnt error message to be printed !! @param code optional exit code @@ -496,6 +507,7 @@ contains end if #endif end subroutine s_mpi_abort + !> Halts all processes until all have reached barrier. impure subroutine s_mpi_barrier #ifdef MFC_MPI @@ -505,6 +517,7 @@ contains call MPI_BARRIER(MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_barrier + !> The subroutine finalizes the MPI execution environment. impure subroutine s_mpi_finalize #ifdef MFC_MPI @@ -514,6 +527,7 @@ contains call MPI_FINALIZE(ierr) #endif end subroutine s_mpi_finalize + !> The goal of this procedure is to populate the buffers of the cell-average conservative variables by communicating with the !! neighboring processors. !! @param q_comm Cell-average conservative variables @@ -545,11 +559,11 @@ contains qbmm_comm = .true. v_size = nVar + 2*nb*nnode buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), & - & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) + & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) else v_size = nVar buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), & - & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) + & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) end if $:GPU_UPDATE(device='[v_size]') @@ -654,7 +668,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*(k & - & + buff_size*l)) + & + buff_size*l)) buff_send(r) = real(pb_in(j, k + pack_offset, l, i - nVar, q), kind=wp) end do end do @@ -670,7 +684,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & - & + 1)*(k + buff_size*l)) + & + 1)*(k + buff_size*l)) buff_send(r) = real(mv_in(j, k + pack_offset, l, i - nVar, q), kind=wp) end do end do @@ -686,7 +700,7 @@ contains do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n & - & + 2*buff_size + 1)*l)) + & + 2*buff_size + 1)*l)) buff_send(r) = real(q_comm(i)%sf(j, k, l + pack_offset), kind=wp) end do end do @@ -702,7 +716,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & - & + buff_size) + (n + 2*buff_size + 1)*l)) + & + buff_size) + (n + 2*buff_size + 1)*l)) buff_send(r) = real(pb_in(j, k, l + pack_offset, i - nVar, q), kind=wp) end do end do @@ -718,7 +732,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & - & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*l)) + & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*l)) buff_send(r) = real(mv_in(j, k, l + pack_offset, i - nVar, q), kind=wp) end do end do @@ -741,7 +755,7 @@ contains call nvtxStartRange("RHS-COMM-SENDRECV-RDMA") call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, & - & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA #:endcall GPU_HOST_DATA @@ -753,7 +767,7 @@ contains call nvtxStartRange("RHS-COMM-SENDRECV-NO-RMDA") call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, & - & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA @@ -765,7 +779,7 @@ contains #:endfor #else call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, src_proc, recv_tag, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) #endif ! Unpack Received Buffer @@ -851,7 +865,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & - & + buff_size) + buff_size*l)) + & + buff_size) + buff_size*l)) pb_in(j, k + unpack_offset, l, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -867,7 +881,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & - & + 1)*((k + buff_size) + buff_size*l)) + & + 1)*((k + buff_size) + buff_size*l)) mv_in(j, k + unpack_offset, l, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -884,7 +898,7 @@ contains do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n & - & + 2*buff_size + 1)*(l + buff_size))) + & + 2*buff_size + 1)*(l + buff_size))) q_comm(i)%sf(j, k, l + unpack_offset) = real(buff_recv(r), kind=stp) #if defined(__INTEL_COMPILER) if (ieee_is_nan(q_comm(i)%sf(j, k, l + unpack_offset))) then @@ -906,7 +920,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & - & + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) + & + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) pb_in(j, k, l + unpack_offset, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -922,7 +936,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & - & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) + & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) mv_in(j, k, l + unpack_offset, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -937,6 +951,7 @@ contains call nvtxEndRange #endif end subroutine s_mpi_sendrecv_variables_buffers + !> The purpose of this procedure is to optimally decompose the computational domain among the available processors. This is !! performed by attempting to award each processor, in each of the coordinate directions, approximately the same number of !! cells, and then recomputing the affected global parameters. @@ -1059,7 +1074,7 @@ contains tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + 10._wp*abs((n + 1) & - & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) + & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) ! Optimization of the initial processor topology do i = 1, num_procs @@ -1077,7 +1092,7 @@ contains num_procs_y = j num_procs_z = num_procs/(i*j) fct_min = abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + abs((n + 1) & - & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) + & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) ierr = 0 end if end if @@ -1091,12 +1106,12 @@ contains ! domain has been established. If not, the simulation exits. if (proc_rank == 0 .and. ierr == -1) then call s_mpi_abort('Unsupported combination of values ' // 'of num_procs, m, n, p and ' & - & // 'weno/muscl/igr_order. Exiting.') + & // 'weno/muscl/igr_order. Exiting.') end if ! Creating new communicator using the Cartesian topology call MPI_CART_CREATE(MPI_COMM_WORLD, 3, (/num_procs_x, num_procs_y, num_procs_z/), (/.true., .true., .true./), & - & .false., MPI_COMM_CART, ierr) + & .false., MPI_COMM_CART, ierr) ! Finding the Cartesian coordinates of the local process call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, proc_coords, ierr) @@ -1162,7 +1177,7 @@ contains if (proc_coords(3) < rem_cells) then z_domain%beg = z_domain%beg + dz*real((p + 1)*proc_coords(3)) z_domain%end = z_domain%end - dz*real((p + 1)*(num_procs_z - proc_coords(3) - 1) - (num_procs_z & - & - rem_cells)) + & - rem_cells)) else z_domain%beg = z_domain%beg + dz*real((p + 1)*proc_coords(3) + rem_cells) z_domain%end = z_domain%end - dz*real((p + 1)*(num_procs_z - proc_coords(3) - 1)) @@ -1204,12 +1219,12 @@ contains ! domain has been established. If not, the simulation exits. if (proc_rank == 0 .and. ierr == -1) then call s_mpi_abort('Unsupported combination of values ' // 'of num_procs, m, n and ' & - & // 'weno/muscl/igr_order. Exiting.') + & // 'weno/muscl/igr_order. Exiting.') end if ! Creating new communicator using the Cartesian topology call MPI_CART_CREATE(MPI_COMM_WORLD, 2, (/num_procs_x, num_procs_y/), (/.true., .true./), .false., MPI_COMM_CART, & - & ierr) + & ierr) ! Finding the Cartesian coordinates of the local process call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 2, proc_coords, ierr) @@ -1276,7 +1291,7 @@ contains if (proc_coords(2) < rem_cells) then y_domain%beg = y_domain%beg + dy*real((n + 1)*proc_coords(2)) y_domain%end = y_domain%end - dy*real((n + 1)*(num_procs_y - proc_coords(2) - 1) - (num_procs_y & - & - rem_cells)) + & - rem_cells)) else y_domain%beg = y_domain%beg + dy*real((n + 1)*proc_coords(2) + rem_cells) y_domain%end = y_domain%end - dy*real((n + 1)*(num_procs_y - proc_coords(2) - 1)) @@ -1369,6 +1384,7 @@ contains end if #endif end subroutine s_mpi_decompose_computational_domain + !> The goal of this procedure is to populate the buffers of the grid variables by communicating with the neighboring processors. !! Note that only the buffers of the cell-width distributions are handled in such a way. This is because the buffers of !! cell-boundary locations may be calculated directly from those of the cell-width distributions. @@ -1390,12 +1406,12 @@ contains ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(-buff_size), buff_size, mpi_p, & - & bc_x%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_x%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only ! Send/receive buffer to/from bc_x%beg/bc_x%beg call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(-buff_size), buff_size, mpi_p, bc_x%beg, 0, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end @@ -1403,12 +1419,12 @@ contains ! Send/receive buffer to/from bc_x%beg/bc_x%end call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(m + 1), buff_size, mpi_p, bc_x%end, 1, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only ! Send/receive buffer to/from bc_x%end/bc_x%end call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(m + 1), buff_size, mpi_p, & - & bc_x%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_x%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if ! END: MPI Communication in x-direction @@ -1421,12 +1437,12 @@ contains ! Send/receive buffer to/from bc_y%end/bc_y%beg call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(-buff_size), buff_size, mpi_p, & - & bc_y%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_y%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only ! Send/receive buffer to/from bc_y%beg/bc_y%beg call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(-buff_size), buff_size, mpi_p, bc_y%beg, 0, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end @@ -1434,12 +1450,12 @@ contains ! Send/receive buffer to/from bc_y%beg/bc_y%end call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(n + 1), buff_size, mpi_p, bc_y%end, 1, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only ! Send/receive buffer to/from bc_y%end/bc_y%end call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(n + 1), buff_size, mpi_p, & - & bc_y%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_y%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if ! END: MPI Communication in y-direction @@ -1453,12 +1469,12 @@ contains ! Send/receive buffer to/from bc_z%end/bc_z%beg call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(-buff_size), buff_size, mpi_p, & - & bc_z%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_z%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only ! Send/receive buffer to/from bc_z%beg/bc_z%beg call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(-buff_size), buff_size, mpi_p, bc_z%beg, 0, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end @@ -1466,18 +1482,19 @@ contains ! Send/receive buffer to/from bc_z%beg/bc_z%end call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(p + 1), buff_size, mpi_p, bc_z%end, 1, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only ! Send/receive buffer to/from bc_z%end/bc_z%end call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(p + 1), buff_size, mpi_p, & - & bc_z%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_z%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if end if ! END: MPI Communication in z-direction #endif end subroutine s_mpi_sendrecv_grid_variables_buffers + #endif !> Module deallocation and/or disassociation procedures diff --git a/src/common/m_nvtx.f90 b/src/common/m_nvtx.f90 index e38997229b..6707bc0d5f 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -9,7 +9,7 @@ module m_nvtx implicit none integer, private :: col(7) = [int(Z'0000ff00'), int(Z'000000ff'), int(Z'00ffff00'), int(Z'00ff00ff'), int(Z'0000ffff'), & - & int(Z'00ff0000'), int(Z'00ffffff')] + & int(Z'00ff0000'), int(Z'00ffffff')] character(len=256), private :: tempName @@ -70,6 +70,7 @@ subroutine nvtxStartRange(name, id) end if #endif end subroutine nvtxStartRange + !> @brief Pops the current NVTX range to end the GPU profiling region. subroutine nvtxEndRange #if defined(MFC_GPU) && defined(__PGI) diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index 57e15d73c4..49d6685499 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -10,15 +10,10 @@ module m_phase_change #ifndef MFC_POST_PROCESS use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use ieee_arithmetic - use m_helper_basic !< Functions to compare floating point numbers implicit none @@ -28,12 +23,12 @@ module m_phase_change !> @name Parameters for the first order transition phase change !> @{ - integer, parameter :: max_iter = 1e8_wp !< max # of iterations - real(wp), parameter :: pCr = 4.94e7_wp !< Critical water pressure - real(wp), parameter :: TCr = 385.05_wp + 273.15_wp !< Critical water temperature - real(wp), parameter :: mixM = 1.0e-8_wp !< threshold for 'mixture cell'. If Y < mixM, phase change does not happen - integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid - integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid + integer, parameter :: max_iter = 1e8_wp !< max # of iterations + real(wp), parameter :: pCr = 4.94e7_wp !< Critical water pressure + real(wp), parameter :: TCr = 385.05_wp + 273.15_wp !< Critical water temperature + real(wp), parameter :: mixM = 1.0e-8_wp !< threshold for 'mixture cell'. If Y < mixM, phase change does not happen + integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid + integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid !> @} !> @name Gibbs free energy phase change parameters @@ -52,6 +47,7 @@ contains ! was never assigned @:ASSERT(.false., "s_relaxation_solver called but it currently does nothing") end subroutine s_relaxation_solver + !> The purpose of this subroutine is to initialize the phase change module by setting the parameters needed for phase change and !! selecting the phase change module that will be used (pT- or pTg-equilibrium) impure subroutine s_initialize_phasechange_module @@ -64,6 +60,7 @@ contains D = ((gs_min(lp) - 1.0_wp)*cvs(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) end subroutine s_initialize_phasechange_module + !> This subroutine is created to activate either the pT- (N fluids) or the pTg-equilibrium (2 fluids for g-equilibrium) model, !! also considering mass depletion, depending on the incoming state conditions. !! @param q_cons_vf Cell-average conservative variables @@ -71,10 +68,10 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid real(wp) :: TS, TSOV, TSSL, TSatOV, & - & TSatSL !< equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor and subcooled liquid - real(wp) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy + & TSatSL !< equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor and subcooled liquid + real(wp) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy real(wp) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses - real(wp) :: TvF !< total volume fraction + real(wp) :: TvF !< total volume fraction ! $:GPU_DECLARE(create='[pS,pSOV,pSSL,TS,TSOV,TSSL,TSatOV,TSatSL]') ! $:GPU_DECLARE(create='[rhoe,dynE,rhos,rho,rM,m1,m2,MCT,TvF]') @@ -258,6 +255,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_infinite_relaxation_k + !> This auxiliary subroutine is created to activate the pT-equilibrium for N fluids !! @param j generic loop iterator for x direction !! @param k generic loop iterator for y direction @@ -280,7 +278,7 @@ contains real(wp), intent(out) :: TS real(wp) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver real(wp) :: p_infpT_sum - integer :: i, ns !< generic loop iterators + integer :: i, ns !< generic loop iterators ! auxiliary variables for the pT-equilibrium solver mCP = 0.0_wp; mQ = 0.0_wp; p_infpT_sum = 0._wp @@ -347,7 +345,7 @@ contains gp = gp + (gs_min(i) - 1.0_wp)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*(rhoe + pS - mQ)/(mCP*(pS + p_infpT(i))) gpp = gpp + (gs_min(i) - 1.0_wp)*q_cons_vf(i + contxb - 1)%sf(j, k, & - & l)*cvs(i)*(p_infpT(i) - rhoe + mQ)/(mCP*(pS + p_infpT(i))**2) + & l)*cvs(i)*(p_infpT(i) - rhoe + mQ)/(mCP*(pS + p_infpT(i))**2) end do hp = 1.0_wp/(rhoe + pS - mQ) + 1.0_wp/(pS + minval(p_infpT)) @@ -359,6 +357,7 @@ contains ! common temperature TS = (rhoe + pS - mQ)/mCP end subroutine s_infinite_pt_relaxation_k + !> This auxiliary subroutine is created to activate the pTg-equilibrium for N fluids under pT and 2 fluids under !! pTg-equilibrium. There is a final common p and T during relaxation !! @param j generic loop iterator for x direction @@ -384,7 +383,7 @@ contains real(wp), dimension(num_fluids) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium #:endif real(wp), dimension(2, 2) :: Jac, InvJac, TJac !< matrices for the Newton Solver - real(wp), dimension(2) :: R2D, DeltamP !< residual and correction array + real(wp), dimension(2) :: R2D, DeltamP !< residual and correction array real(wp) :: Om ! underrelaxation factor real(wp) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver real(wp) :: ml, mT, dFdT, dTdm, dTdp @@ -415,7 +414,7 @@ contains R2D(1) = 0.0_wp; R2D(2) = 0.0_wp DeltamP(1) = 0.0_wp; DeltamP(2) = 0.0_wp do while (((sqrt(R2D(1)**2 + R2D(2)**2) > ptgalpha_eps) .and. ((sqrt(R2D(1)**2 + R2D(2)**2)/rhoe) > (ptgalpha_eps/1.e6_wp) & - & )) .or. (ns == 0)) + & )) .or. (ns == 0)) ! Updating counter for the iterative procedure ns = ns + 1 @@ -455,15 +454,15 @@ contains mT = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, l) TS = 1/(mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp) & - & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) dFdT = -(cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*log(TS) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) - 1)*log(pS & - & + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pS + ps_inf(vp)) + & + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pS + ps_inf(vp)) dTdm = -(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)))*TS**2 dTdp = (mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))**2 + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp))**2 - cvs(vp) & - & *(gs_min(vp) - 1)/(pS + ps_inf(vp))**2) + mCVGP2)*TS**2 + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))**2) + mCVGP2)*TS**2 ! F = (F1,F2) is the function whose roots we are looking for ! x = (m1, p) are the independent variables. m1 = mass of the first participant fluid, p = pressure @@ -529,7 +528,7 @@ contains mT = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, l) TS = 1/(mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp) & - & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) ! Gibbs Free Energy Equality condition (DG) R2D(1) = TS*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*(1 - log(TS)) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) & @@ -544,6 +543,7 @@ contains ! common temperature TS = (rhoe + pS - mQ)/mCP end subroutine s_infinite_ptg_relaxation_k + !> This auxiliary subroutine corrects the partial densities of the REACTING fluids in case one of them is negative but their sum !! is positive. Inert phases are not corrected at this moment !! @param MCT partial density correction parameter @@ -588,6 +588,7 @@ contains q_cons_vf(vp + contxb - 1)%sf(j, k, l) = MCT*rM end if end subroutine s_correct_partial_densities + !> This auxiliary subroutine finds the Saturation temperature for a given saturation pressure through a newton solver !! @param pSat Saturation Pressure !! @param TSat Saturation Temperature @@ -629,11 +630,11 @@ contains ! calculating residual FT = TSat*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*(1 - log(TSat)) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) & - & - 1)*log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp))) + qvs(lp) - qvs(vp) + & - 1)*log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp))) + qvs(lp) - qvs(vp) ! calculating the jacobian dFdT = -(cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*log(TSat) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) - 1) & - & *log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp)) + & *log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp)) ! updating saturation temperature TSat = TSat - Om*FT/dFdT @@ -642,8 +643,10 @@ contains end do end if end subroutine s_TSat + !> This subroutine finalizes the phase change module impure subroutine s_finalize_relaxation_solver_module end subroutine s_finalize_relaxation_solver_module + #endif end module m_phase_change diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index f36c4262b6..16bb266de9 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -8,15 +8,10 @@ !> @brief Conservative-to-primitive variable conversion, mixture property evaluation, and pressure computation module m_variables_conversion use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers - use m_helper - use m_thermochem, only: num_species, get_temperature, get_pressure, gas_constant, get_mixture_molecular_weight, & & get_mixture_energy_mass @@ -55,10 +50,10 @@ module m_variables_conversion integer :: is1b, is2b, is3b, is1e, is2e, is3e $:GPU_DECLARE(create='[is1b, is2b, is3b, is1e, is2e, is3e]') - real(wp), allocatable, dimension(:,:,:), public :: rho_sf !< Scalar density function - real(wp), allocatable, dimension(:,:,:), public :: gamma_sf !< Scalar sp. heat ratio function + real(wp), allocatable, dimension(:,:,:), public :: rho_sf !< Scalar density function + real(wp), allocatable, dimension(:,:,:), public :: gamma_sf !< Scalar sp. heat ratio function real(wp), allocatable, dimension(:,:,:), public :: pi_inf_sf !< Scalar liquid stiffness function - real(wp), allocatable, dimension(:,:,:), public :: qv_sf !< Scalar liquid energy reference function + real(wp), allocatable, dimension(:,:,:), public :: qv_sf !< Scalar liquid energy reference function contains !> Dispatch to the s_convert_mixture_to_mixture_variables and s_convert_species_to_mixture_variables subroutines. Replaces a @@ -88,6 +83,7 @@ contains call s_convert_species_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv, Re_K, G_K, G) end if end subroutine s_convert_to_mixture_variables + !> This procedure conditionally calculates the appropriate pressure !! @param energy Energy !! @param alf Void Fraction @@ -163,6 +159,7 @@ contains call get_pressure(rho, T, Y_rs, pres) #:endif end subroutine s_compute_pressure + !> This subroutine is designed for the gamma/pi_inf model and provided a set of either conservative or primitive variables, !! transfers the density, specific heat ratio function and the liquid stiffness function from q_vf to rho, gamma and pi_inf. !! @param q_vf conservative or primitive variables @@ -196,6 +193,7 @@ contains qv_sf(i, j, k) = qv #endif end subroutine s_convert_mixture_to_mixture_variables + !> This subroutine is designed for the volume fraction model and provided a set of either conservative or primitive variables, !! computes the density, the specific heat ratio function and the liquid stiffness function from q_vf and stores the results !! into rho, gamma and pi_inf. @@ -221,7 +219,7 @@ contains real(wp), optional, intent(out) :: G_K real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K !< real(wp), optional, dimension(num_fluids), intent(in) :: G - integer :: i, j !< Generic loop iterator + integer :: i, j !< Generic loop iterator ! Computing the density, the specific heat ratio function and the ! liquid stiffness function, respectively @@ -276,6 +274,7 @@ contains qv_sf(k, l, r) = qv #endif end subroutine s_convert_species_to_mixture_variables + !> @brief GPU-accelerated conversion of species volume fractions and partial densities to mixture density, gamma, pi_inf, and !! qv. subroutine s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K, G_K, G) @@ -348,6 +347,7 @@ contains end if #endif end subroutine s_convert_species_to_mixture_variables_acc + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_variables_conversion_module @@ -430,6 +430,7 @@ contains end if #endif end subroutine s_initialize_variables_conversion_module + !> @brief Initializes bubble mass-vapor values at quadrature nodes from the conserved moment statistics. subroutine s_initialize_mv(qK_cons_vf, mv) type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf @@ -456,6 +457,7 @@ contains end do end do end subroutine s_initialize_mv + !> @brief Initializes bubble internal pressures at quadrature nodes using isothermal relations from the Preston model. subroutine s_initialize_pb(qK_cons_vf, mv, pb) type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf @@ -476,18 +478,19 @@ contains ! PRESTON (ISOTHERMAL) pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 1, & - & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 2, & - & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 3, & - & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 4, & - & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) end do end do end do end do end subroutine s_initialize_pb + !> The following procedure handles the conversion between the conservative variables and the primitive variables. !! @param qK_cons_vf Conservative variables !! @param q_T_sf Temperature scalar field @@ -539,16 +542,16 @@ contains ! If in simulation, use acc mixture subroutines if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K, G_K, Gs_vc) + & Re_K, G_K, Gs_vc) else call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K) + & Re_K) end if #else ! If pre-processing, use non acc mixture subroutines if (elasticity) then call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, rho_K, gamma_K, pi_inf_K, qv_K, Re_K, G_K, & - & fluid_pp(:)%G) + & fluid_pp(:)%G) else call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, rho_K, gamma_K, pi_inf_K, qv_K) end if @@ -678,17 +681,17 @@ contains if (mhd) then if (n == 0) then pres_mag = 0.5_wp*(Bx0**2 + qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, & - & l)**2) + & l)**2) else pres_mag = 0.5_wp*(qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, & - & l)**2 + qK_cons_vf(B_idx%beg + 2)%sf(j, k, l)**2) + & l)**2 + qK_cons_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if else pres_mag = 0._wp end if call s_compute_pressure(qK_cons_vf(E_idx)%sf(j, k, l), qK_cons_vf(alf_idx)%sf(j, k, l), dyn_pres_K, pi_inf_K, & - & gamma_K, rho_K, qv_K, rhoYks, pres, T, pres_mag=pres_mag) + & gamma_K, rho_K, qv_K, rhoYks, pres, T, pres_mag=pres_mag) qK_prim_vf(E_idx)%sf(j, k, l) = pres @@ -753,11 +756,11 @@ contains ! subtracting elastic contribution for pressure calculation if (G_K > verysmall) then qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - ((qK_prim_vf(i)%sf(j, k, & - & l)**2._wp)/(4._wp*G_K))/gamma_K + & l)**2._wp)/(4._wp*G_K))/gamma_K ! Double for shear stresses if (any(i == shear_indices)) then qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - ((qK_prim_vf(i)%sf(j, k, & - & l)**2._wp)/(4._wp*G_K))/gamma_K + & l)**2._wp)/(4._wp*G_K))/gamma_K end if end if end do @@ -792,6 +795,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_convert_conservative_to_primitive_variables + !> The following procedure handles the conversion between the primitive variables and the conservative variables. !! @param q_prim_vf Primitive variables !! @param q_cons_vf Conservative variables @@ -926,10 +930,10 @@ contains if (mhd) then if (n == 0) then pres_mag = 0.5_wp*(Bx0**2 + q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, & - & k, l)**2) + & k, l)**2) else pres_mag = 0.5_wp*(q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, & - & l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) + & l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if q_cons_vf(E_idx)%sf(j, k, l) = gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pres_mag + pi_inf + qv else if ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then @@ -938,7 +942,7 @@ contains else if ((model_eqns /= 4) .and. (bubbles_euler)) then ! \tilde{E} = dyn_pres + (1-\alf)(\Gamma p_l + \Pi_inf) q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + (1._wp - q_prim_vf(alf_idx)%sf(j, k, & - & l))*(gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) + & l))*(gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) else ! Tait EOS, no conserved energy variable q_cons_vf(E_idx)%sf(j, k, l) = 0._wp @@ -950,8 +954,8 @@ contains do i = 1, num_fluids ! internal energy calculation for each of the fluids q_cons_vf(i + intxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, & - & l)*(gammas(i)*q_prim_vf(E_idx)%sf(j, k, & - & l) + pi_infs(i)) + q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) + & l)*(gammas(i)*q_prim_vf(E_idx)%sf(j, k, l) + pi_infs(i)) + q_cons_vf(i + contxb - 1)%sf(j, k, & + & l)*qvs(i) end do end if @@ -1004,11 +1008,11 @@ contains ! adding elastic contribution if (G > verysmall) then q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + (q_prim_vf(i)%sf(j, k, & - & l)**2._wp)/(4._wp*G) + & l)**2._wp)/(4._wp*G) ! Double for shear stresses if (any(i == shear_indices)) then q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + (q_prim_vf(i)%sf(j, k, & - & l)**2._wp)/(4._wp*G) + & l)**2._wp)/(4._wp*G) end if end if end do @@ -1038,6 +1042,7 @@ contains end if #endif end subroutine s_convert_primitive_to_conservative_variables + !> The following subroutine handles the conversion between the primitive variables and the Eulerian flux variables. !! @param qK_prim_vf Primitive variables !! @param FK_vf Flux variables @@ -1118,7 +1123,7 @@ contains pres_K = qK_prim_vf(j, k, l, E_idx) if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K, G_K, Gs_vc) + & Re_K, G_K, Gs_vc) else call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K) end if @@ -1187,6 +1192,7 @@ contains $:END_GPU_PARALLEL_LOOP() #endif end subroutine s_convert_primitive_to_flux_variables + !> This subroutine computes partial densities and volume fractions subroutine s_compute_species_fraction(q_vf, k, l, r, alpha_rho_K, alpha_K) $:GPU_ROUTINE(function_name='s_compute_species_fraction', parallelism='[seq]', cray_noinline=True) @@ -1235,6 +1241,7 @@ contains if (num_fluids == 1 .and. bubbles_euler) alpha_K(1) = q_vf(advxb)%sf(k, l, r) end subroutine s_compute_species_fraction + !> @brief Deallocates fluid property arrays and post-processing fields allocated during module initialization. impure subroutine s_finalize_variables_conversion_module() ! Deallocating the density, the specific heat ratio function and the @@ -1255,6 +1262,7 @@ contains end if #endif end subroutine s_finalize_variables_conversion_module + #ifndef MFC_PRE_PROCESS !> @brief Computes the speed of sound from thermodynamic state variables, supporting multiple equation-of-state models. subroutine s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, vel_sum, c_c, c, qv) @@ -1314,6 +1322,7 @@ contains end if end if end subroutine s_compute_speed_of_sound + #endif #ifndef MFC_PRE_PROCESS @@ -1347,5 +1356,6 @@ contains c_fast = sqrt(0.5_wp*(term + sqrt(disc))) end subroutine s_compute_fast_magnetosonic_speed + #endif end module m_variables_conversion diff --git a/src/post_process/m_checker.fpp b/src/post_process/m_checker.fpp index ecca4fe836..ff0be224a5 100644 --- a/src/post_process/m_checker.fpp +++ b/src/post_process/m_checker.fpp @@ -7,11 +7,8 @@ !> @brief Validates post-process input parameters and output format consistency module m_checker use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers - use m_helper implicit none @@ -22,6 +19,7 @@ contains !> Checks compatibility of parameters in the input file. Used by the post_process stage impure subroutine s_check_inputs end subroutine s_check_inputs + !> Checks constraints on fft_wrt impure subroutine s_check_inputs_fft integer :: num_procs_y, num_procs_z diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index d6cf2856e8..4477e325a9 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -9,17 +9,11 @@ module m_data_input #endif use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_mpi_common - use m_compile_specific - use m_boundary_common - use m_helper implicit none @@ -93,6 +87,7 @@ impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_ ! Computing the cell-center locations cc_array(0:size_dim) = cb_array(-1:size_dim - 1) + d_array(0:size_dim)/2._wp end subroutine s_read_grid_data_direction + #ifdef MFC_MPI !> Helper subroutine to setup MPI data I/O parameters !! @param data_size Local array size (output) @@ -122,6 +117,7 @@ impure subroutine s_setup_mpi_io_params(data_size, m_MOK, n_MOK, p_MOK, WP_MOK, str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) end subroutine s_setup_mpi_io_params + #endif !> Helper subroutine to read IB data files @@ -182,6 +178,7 @@ impure subroutine s_read_ib_data_files(file_loc_base, t_step) call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if end subroutine s_read_ib_data_files + !> Helper subroutine to allocate field arrays for given dimensionality !! @param local_start_idx Starting index for allocation !! @param end_x End index for x dimension @@ -204,6 +201,7 @@ impure subroutine s_allocate_field_arrays(local_start_idx, end_x, end_y, end_z) allocate (q_T_sf%sf(local_start_idx:end_x, local_start_idx:end_y, local_start_idx:end_z)) end if end subroutine s_allocate_field_arrays + !> This subroutine is called at each time-step that has to be post-processed in order to read the raw data files present in the !! corresponding time-step directory and to populate the associated grid and conservative variables. !! @param t_step Current time-step @@ -285,6 +283,7 @@ impure subroutine s_read_serial_data_files(t_step) ! Reading IB data using helper subroutine call s_read_ib_data_files(t_step_dir) end subroutine s_read_serial_data_files + !> This subroutine is called at each time-step that has to be post-processed in order to parallel-read the raw data files !! present in the corresponding time-step directory and to populate the associated grid and conservative variables. !! @param t_step Current time-step @@ -414,6 +413,7 @@ impure subroutine s_read_parallel_data_files(t_step) end if #endif end subroutine s_read_parallel_data_files + #ifdef MFC_MPI !> Helper subroutine to read parallel conservative variable data !! @param t_step Current time-step @@ -526,6 +526,7 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, end if end if end subroutine s_read_parallel_conservative_data + #endif !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module @@ -582,6 +583,7 @@ impure subroutine s_initialize_data_input_module s_read_data_files => s_read_parallel_data_files end if end subroutine s_initialize_data_input_module + !> Deallocation procedures for the module impure subroutine s_finalize_data_input_module integer :: i !< Generic loop iterator diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 4649573867..e285fdc1ab 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -5,17 +5,11 @@ !> @brief Writes post-processed grid and flow-variable data to Silo-HDF5 or binary database files module m_data_output use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters - use m_derived_variables !< Procedures used to compute quantities derived - use m_mpi_proxy ! Message passing interface (MPI) module proxy - use m_compile_specific - use m_helper - use m_variables_conversion implicit none @@ -121,7 +115,7 @@ contains 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)) 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)) + & -offset_x%beg:m + offset_x%end)) end if end if @@ -176,10 +170,10 @@ contains 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/) + & 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/) + & p + offset_z%beg + offset_z%end + 2/) end if else if (n > 0) then lo_offset(:) = (/offset_x%beg, offset_y%beg/) @@ -386,6 +380,7 @@ contains ! END: Querying Number of Flow Variable(s) in Binary Output end subroutine s_initialize_data_output_module + !> @brief Compute the cell-index bounds for the user-specified partial output domain in each coordinate direction. impure subroutine s_define_output_region integer :: i @@ -418,6 +413,7 @@ contains end if #:endfor end subroutine s_define_output_region + !> @brief Open (or create) the Silo-HDF5 or Binary formatted database slave and master files for a given time step. impure subroutine s_open_formatted_database_file(t_step) ! Description: This subroutine opens a new formatted database file, or @@ -468,7 +464,7 @@ contains if (dbroot == -1) then call s_mpi_abort('Unable to create Silo-HDF5 database ' // 'master file ' // trim(file_loc) // '. ' & - & // 'Exiting.') + & // 'Exiting.') end if end if @@ -497,7 +493,7 @@ contains ! eventually be stored in it 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 + & z_output_idx%end - z_output_idx%beg, dbvars else write (dbfile) m, n, p, dbvars end if @@ -523,6 +519,7 @@ contains end if end if end subroutine s_open_formatted_database_file + !> @brief Open the interface data file for appending extracted interface coordinates. impure subroutine s_open_intf_data_file() character(LEN=path_len + 3*name_len) :: file_path !< @@ -534,6 +531,7 @@ contains ! Opening the simulation data file open (211, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') end subroutine s_open_intf_data_file + !> @brief Open the energy data file for appending volume-integrated energy budget quantities. impure subroutine s_open_energy_data_file() character(LEN=path_len + 3*name_len) :: file_path !< @@ -545,6 +543,7 @@ contains ! Opening the simulation data file open (251, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') end subroutine s_open_energy_data_file + !> @brief Write the computational grid (cell-boundary coordinates) to the formatted database slave and master files. impure subroutine s_write_grid_to_formatted_database_file(t_step) ! Description: The general objective of this subroutine is to write the @@ -616,7 +615,7 @@ contains 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) + & ierr) err = DBFREEOPTLIST(optlist) end if @@ -630,10 +629,10 @@ contains err = DBADDIOPT(optlist, DBOPT_HI_OFFSET, 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) + & DB_COLLINEAR, 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) + & DB_COLLINEAR, optlist, ierr) end if err = DBFREEOPTLIST(optlist) else if (n > 0) then @@ -641,14 +640,14 @@ contains err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) err = DBADDIOPT(optlist, DBOPT_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) + & DB_COLLINEAR, optlist, ierr) err = DBFREEOPTLIST(optlist) else err = DBMKOPTLIST(2, optlist) err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) err = DBADDIOPT(optlist, DBOPT_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) + & DB_DOUBLE, DB_COLLINEAR, optlist, ierr) err = DBFREEOPTLIST(optlist) end if ! END: Silo-HDF5 Database Format @@ -664,7 +663,7 @@ contains 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) + & z_cb(z_output_idx%beg - 1:z_output_idx%end) else write (dbfile) x_cb, y_cb, z_cb end if @@ -715,6 +714,7 @@ contains end if end if end subroutine s_write_grid_to_formatted_database_file + !> @brief Write a single flow variable field to the formatted database slave and master files for a given time step. impure subroutine s_write_variable_to_formatted_database_file(varname, t_step) ! Description: The goal of this subroutine is to write to the formatted @@ -776,7 +776,7 @@ contains 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) + & optlist, ierr) err = DBFREEOPTLIST(optlist) end if @@ -836,17 +836,17 @@ contains 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) + & 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) + & 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) + & 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) + & 1, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) end if end if #:endfor @@ -884,6 +884,7 @@ contains end if end if end subroutine s_write_variable_to_formatted_database_file + !> Subroutine that writes the post processed results in the folder 'lag_bubbles_data' !! @param t_step Current time step impure subroutine s_write_lag_bubbles_results_to_text(t_step) @@ -965,7 +966,7 @@ contains call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_null, ierr) allocate (MPI_IO_DATA_lg_bubbles(file_tot_part, 1:lag_io_vars)) @@ -1034,6 +1035,7 @@ contains call MPI_FILE_CLOSE(ifile, ierr) #endif end subroutine s_write_lag_bubbles_results_to_text + !> @brief Read Lagrangian bubble restart data and write bubble positions and scalar fields to the Silo database. impure subroutine s_write_lag_bubbles_to_formatted_database_file(t_step) integer, intent(in) :: t_step @@ -1140,7 +1142,7 @@ contains ! Skip extended header disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lg_bubbles, lag_io_vars*nBub, mpi_p, status, ierr) @@ -1191,7 +1193,7 @@ contains if (lag_betaC_wrt) call s_write_lag_variable_to_formatted_database_file('part_betaC', t_step, betaC, nBub) deallocate (bub_id, px, py, pz, ppx, ppy, ppz, vx, vy, vz, radius, rvel, rnot, rmax, rmin, dphidt, pressure, mv, mg, & - & betaT, betaC) + & betaT, betaC) deallocate (MPI_IO_DATA_lg_bubbles) else call MPI_TYPE_CONTIGUOUS(0, mpi_p, view, ierr) @@ -1201,7 +1203,7 @@ contains ! Skip extended header disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -1241,6 +1243,7 @@ contains end if #endif end subroutine s_write_lag_bubbles_to_formatted_database_file + !> @brief Write a single Lagrangian bubble point-variable to the Silo database slave and master files. subroutine s_write_lag_variable_to_formatted_database_file(varname, t_step, data, nBubs) character(len=*), intent(in) :: varname @@ -1263,7 +1266,7 @@ contains 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) + & DB_F77NULL, ierr) end if err = DBPUTPV1(dbfile, trim(varname), len_trim(varname), 'lag_bubbles', 11, data, nBubs, DB_DOUBLE, DB_F77NULL, ierr) @@ -1276,13 +1279,14 @@ contains 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) + & 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) end if end subroutine s_write_lag_variable_to_formatted_database_file + impure subroutine s_write_ib_state_files() character(len=len_trim(case_dir) + 4*name_len) :: in_file, out_file, file_loc integer :: iu_in, ios, i, rec_id @@ -1308,19 +1312,19 @@ contains call s_mpi_abort('Cannot open IB state output file: ' // trim(out_file)) end if write (iu_out(i), & - & '(A)') 'mytime fx fy fz Tau_x Tau_y Tau_z vx vy vz omega_x omega_y omega_z angle_x angle_y angle_z x_c y_c z_c' + & '(A)') 'mytime fx fy fz Tau_x Tau_y Tau_z vx vy vz omega_x omega_y omega_z angle_x angle_y angle_z x_c y_c z_c' end do do read (iu_in, iostat=ios) rec_time, rec_id, rec_force, rec_torque, rec_vel, rec_angular_vel, rec_angles, & - & rec_centroid(1), rec_centroid(2), rec_centroid(3) + & rec_centroid(1), rec_centroid(2), rec_centroid(3) if (ios /= 0) exit if (rec_id >= 1 .and. rec_id <= num_ibs) then write (iu_out(rec_id), '(19(ES24.16E3,1X))') rec_time, rec_force(1), rec_force(2), rec_force(3), rec_torque(1), & - & rec_torque(2), rec_torque(3), rec_vel(1), rec_vel(2), rec_vel(3), rec_angular_vel(1), & - & rec_angular_vel(2), rec_angular_vel(3), rec_angles(1), rec_angles(2), rec_angles(3), rec_centroid(1), & - & rec_centroid(2), rec_centroid(3) + & rec_torque(2), rec_torque(3), rec_vel(1), rec_vel(2), rec_vel(3), rec_angular_vel(1), rec_angular_vel(2), & + & rec_angular_vel(3), rec_angles(1), rec_angles(2), rec_angles(3), rec_centroid(1), rec_centroid(2), & + & rec_centroid(3) end if end do @@ -1330,6 +1334,7 @@ contains end do deallocate (iu_out) end subroutine s_write_ib_state_files + !> @brief Extract the volume-fraction interface contour from primitive fields and write the coordinates to the interface data !! file. impure subroutine s_write_intf_data_file(q_prim_vf) @@ -1414,6 +1419,7 @@ contains end do end if end subroutine s_write_intf_data_file + !> @brief Compute volume-integrated kinetic, potential, and internal energies and write the energy budget to the energy data !! file. impure subroutine s_write_energy_data_file(q_prim_vf, q_cons_vf) @@ -1504,6 +1510,7 @@ contains write (251, '(10X, 8F24.8)') Elp, Egint, Elk, Egk, Et, Vb, Vl, MaxMa_glb end if end subroutine s_write_energy_data_file + !> @brief Close the formatted database slave file and, for the root process, the master file. impure subroutine s_close_formatted_database_file() ! Description: The purpose of this subroutine is to close any formatted @@ -1531,14 +1538,17 @@ contains if (n == 0 .and. proc_rank == 0) close (dbroot) end if end subroutine s_close_formatted_database_file + !> @brief Close the interface data file. impure subroutine s_close_intf_data_file() close (211) end subroutine s_close_intf_data_file + !> @brief Close the energy data file. impure subroutine s_close_energy_data_file() close (251) end subroutine s_close_energy_data_file + !> @brief Deallocate module arrays and release all data-output resources. impure subroutine s_finalize_data_output_module() ! Description: Deallocation procedures for the module diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 48a236f917..8ce4d51acb 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -6,13 +6,9 @@ module m_derived_variables use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers - use m_variables_conversion implicit none @@ -85,12 +81,13 @@ contains flg = 0 end if end subroutine s_initialize_derived_variables_module + !> This subroutine receives as input the specific heat ratio function, gamma_sf, and derives from it the specific heat ratio. !! The latter is stored in the derived flow quantity storage variable, q_sf. !! @param q_sf Specific heat ratio subroutine s_derive_specific_heat_ratio(q_sf) real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators @@ -103,13 +100,14 @@ contains end do end do end subroutine s_derive_specific_heat_ratio + !> This subroutine admits as inputs the specific heat ratio function and the liquid stiffness function, gamma_sf and pi_inf_sf, !! respectively. These are used to calculate the values of the liquid stiffness, which are stored in the derived flow quantity !! storage variable, q_sf. !! @param q_sf Liquid stiffness subroutine s_derive_liquid_stiffness(q_sf) real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators @@ -123,6 +121,7 @@ contains end do end do end subroutine s_derive_liquid_stiffness + !> This subroutine admits as inputs the primitive variables, the density, the specific heat ratio function and liquid stiffness !! function. It then computes from those variables the values of the speed of sound, which are stored in the derived flow !! quantity storage variable, q_sf. @@ -132,7 +131,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators @@ -147,12 +146,12 @@ contains ! Compute mixture sound speed if (alt_soundspeed .neqv. .true.) then q_sf(i, j, k) = (((gamma_sf(i, j, k) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_inf_sf(i, j, & - & k))/(gamma_sf(i, j, k)*rho_sf(i, j, k))) + & k))/(gamma_sf(i, j, k)*rho_sf(i, j, k))) else blkmod1 = ((gammas(1) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_infs(2))/gammas(2) q_sf(i, j, k) = (1._wp/(rho_sf(i, j, k)*(q_prim_vf(adv_idx%beg)%sf(i, j, & - & k)/blkmod1 + (1._wp - q_prim_vf(adv_idx%beg)%sf(i, j, k))/blkmod2))) + & k)/blkmod1 + (1._wp - q_prim_vf(adv_idx%beg)%sf(i, j, k))/blkmod2))) end if if (mixture_err .and. q_sf(i, j, k) < 0._wp) then @@ -164,6 +163,7 @@ contains end do end do end subroutine s_derive_sound_speed + !> This subroutine derives the flux_limiter at cell boundary i+1/2. This is an approximation because the velocity used to !! determine the upwind direction is the velocity at the cell center i instead of the contact velocity at the cell boundary from !! the Riemann solver. @@ -175,10 +175,10 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf real(wp) :: top, bottom, slope !< Flux limiter calcs - integer :: j, k, l !< Generic loop iterators + integer :: j, k, l !< Generic loop iterators do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end @@ -242,6 +242,7 @@ contains end do end do end subroutine s_derive_flux_limiter + !> Computes the solution to the linear system Ax=b w/ sol = x !! @param A Input matrix !! @param b right-hane-side @@ -285,6 +286,7 @@ contains end do end do end subroutine s_solve_linear_system + !> This subroutine receives as inputs the indicator of the component of the vorticity that should be outputted and the primitive !! variables. From those inputs, it proceeds to calculate values of the desired vorticity component, which are subsequently !! stored in derived flow quantity storage variable, q_sf. @@ -296,7 +298,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf integer :: j, k, l, r !< Generic loop iterators @@ -310,11 +312,11 @@ 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(mom_idx%end)%sf(j, r + k, l) - fd_coeff_z(r, & - & l)*q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l)) + & k)*y_cc(r + k)*q_prim_vf(mom_idx%end)%sf(j, r + k, l) - fd_coeff_z(r, & + & l)*q_prim_vf(mom_idx%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(mom_idx%end)%sf(j, r + k, & - & l) - fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l) + & l) - fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l) end if end do end do @@ -331,10 +333,10 @@ 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(mom_idx%beg)%sf(j, k, & - & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%end)%sf(r + j, k, l) + & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%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(mom_idx%beg)%sf(j, k, & - & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%end)%sf(r + j, k, l) + & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%end)%sf(r + j, k, l) end if end do end do @@ -350,13 +352,14 @@ contains do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_x(r, j)*q_prim_vf(mom_idx%beg + 1)%sf(r + j, k, & - & l) - fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg)%sf(j, r + k, l) + & l) - fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg)%sf(j, r + k, l) end do end do end do end do end if end subroutine s_derive_vorticity_component + !> This subroutine gets as inputs the primitive variables. From those inputs, it proceeds to calculate the value of the Q_M !! function, which are subsequently stored in the derived flow quantity storage variable, q_sf. !! @param q_prim_vf Primitive variables @@ -365,7 +368,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf real(wp), dimension(1:3, 1:3) :: q_jacobian_sf, S, S2, O, O2 real(wp) :: trS, Q, IIS @@ -381,13 +384,13 @@ contains do jj = 1, 3 ! d()/dx q_jacobian_sf(jj, 1) = q_jacobian_sf(jj, 1) + fd_coeff_x(r, & - & j)*q_prim_vf(mom_idx%beg + jj - 1)%sf(r + j, k, l) + & j)*q_prim_vf(mom_idx%beg + jj - 1)%sf(r + j, k, l) ! d()/dy q_jacobian_sf(jj, 2) = q_jacobian_sf(jj, 2) + fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg + jj - 1)%sf(j, & - & r + k, l) + & r + k, l) ! d()/dz q_jacobian_sf(jj, 3) = q_jacobian_sf(jj, 3) + fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + jj - 1)%sf(j, & - & k, r + l) + & k, r + l) end do end do @@ -416,6 +419,7 @@ contains end do end do end subroutine s_derive_qm + !> This subroutine gets as inputs the primitive variables. From those inputs, it proceeds to calculate the Liutex vector and its !! magnitude based on Xu et al. (2019). !! @param q_prim_vf Primitive variables @@ -424,23 +428,23 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(out) :: liutex_mag !< Liutex magnitude + & intent(out) :: liutex_mag !< Liutex magnitude real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, nm), & - & intent(out) :: liutex_axis !< Liutex rigid rotation axis - - character, parameter :: ivl = 'N' !< compute left eigenvectors - character, parameter :: ivr = 'V' !< compute right eigenvectors - real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor - real(wp), dimension(nm) :: lr, li !< real and imaginary parts of eigenvalues - real(wp), dimension(nm, nm) :: vl, vr !< left and right eigenvectors - integer, parameter :: lwork = 4*nm !< size of work array (4*nm recommended) - real(wp), dimension(lwork) :: work !< work array + & intent(out) :: liutex_axis !< Liutex rigid rotation axis + + character, parameter :: ivl = 'N' !< compute left eigenvectors + character, parameter :: ivr = 'V' !< compute right eigenvectors + real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor + real(wp), dimension(nm) :: lr, li !< real and imaginary parts of eigenvalues + real(wp), dimension(nm, nm) :: vl, vr !< left and right eigenvectors + integer, parameter :: lwork = 4*nm !< size of work array (4*nm recommended) + real(wp), dimension(lwork) :: work !< work array integer :: info - real(wp), dimension(nm) :: eigvec !< real eigenvector - real(wp) :: eigvec_mag !< magnitude of real eigenvector - real(wp) :: omega_proj !< projection of vorticity on real eigenvector - real(wp) :: lci !< imaginary part of complex eigenvalue + real(wp), dimension(nm) :: eigvec !< real eigenvector + real(wp) :: eigvec_mag !< magnitude of real eigenvector + real(wp) :: omega_proj !< projection of vorticity on real eigenvector + real(wp) :: lci !< imaginary part of complex eigenvalue real(wp) :: alpha integer :: j, k, l, r, i !< Generic loop iterators integer :: idx @@ -488,7 +492,7 @@ contains ! Compute vorticity projected on the eigenvector omega_proj = (vgt(3, 2) - vgt(2, 3))*eigvec(1) + (vgt(1, 3) - vgt(3, 1))*eigvec(2) + (vgt(2, 1) - vgt(1, & - & 2))*eigvec(3) + & 2))*eigvec(3) ! As eigenvector can have +/- signs, we can choose the sign ! so that omega_proj is positive @@ -516,6 +520,7 @@ contains end do end do end subroutine s_derive_liutex + !> This subroutine gets as inputs the conservative variables and density. From those inputs, it proceeds to calculate the values !! of the numerical Schlieren function, which are subsequently stored in the derived flow quantity storage variable, q_sf. !! @param q_cons_vf Conservative variables @@ -524,7 +529,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf real(wp) :: drho_dx, drho_dy, drho_dz !< !! Spatial derivatives of the density in the x-, y- and z-directions @@ -613,7 +618,7 @@ contains do i = 1, adv_idx%end - E_idx q_sf(j, k, l) = q_sf(j, k, l) - schlieren_alpha(i)*q_cons_vf(i + E_idx)%sf(j, k, l)*gm_rho_sf(j, k, & - & l)/gm_rho_max(1) + & l)/gm_rho_max(1) end do end do end do @@ -625,6 +630,7 @@ contains ! the computation, the exponential of the inside quantity is taken. q_sf = exp(q_sf) end subroutine s_derive_numerical_schlieren_function + !> Deallocation procedures for the module impure subroutine s_finalize_derived_variables_module ! Deallocating the variable containing the gradient magnitude of the diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index 5595f0f0db..fe1ffad39d 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -11,17 +11,15 @@ module m_global_parameters #endif use m_derived_types !< Definitions of the derived types - use m_helper_basic !< Functions to compare floating point numbers - use m_thermochem, only: num_species, species_names implicit none !> @name Logistics !> @{ - integer :: num_procs !< Number of processors - character(LEN=path_len) :: case_dir !< Case folder location + integer :: num_procs !< Number of processors + character(LEN=path_len) :: case_dir !< Case folder location !> @} ! Computational Domain Parameters @@ -74,9 +72,9 @@ module m_global_parameters !! region, this region is used to store information outside the computational !! domain based on the boundary conditions. - integer :: t_step_start !< First time-step directory - integer :: t_step_stop !< Last time-step directory - integer :: t_step_save !< Interval between consecutive time-step directory + integer :: t_step_start !< First time-step directory + integer :: t_step_stop !< Last time-step directory + integer :: t_step_save !< Interval between consecutive time-step directory !> @name IO options for adaptive time-stepping !> @{ @@ -94,28 +92,28 @@ module m_global_parameters !> @name Simulation Algorithm Parameters !> @{ - integer :: model_eqns !< Multicomponent flow model - integer :: num_fluids !< Number of different fluids present in the flow - logical :: relax !< phase change - integer :: relax_model !< Phase change relaxation model - logical :: mpp_lim !< Maximum volume fraction limiter - integer :: sys_size !< Number of unknowns in the system of equations - integer :: recon_type !< Which type of reconstruction to use - integer :: weno_order !< Order of accuracy for the WENO reconstruction - integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction - logical :: mixture_err !< Mixture error limiter - logical :: alt_soundspeed !< Alternate sound speed - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity for RMHD - logical :: hypoelasticity !< Turn hypoelasticity on - logical :: hyperelasticity !< Turn hyperelasticity on - logical :: elasticity !< elasticity modeling, true for hyper or hypo - integer :: b_size !< Number of components in the b tensor - integer :: tensor_size !< Number of components in the nonsymmetric tensor - logical :: cont_damage !< Continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD - logical :: igr !< enable IGR - integer :: igr_order !< IGR reconstruction order + integer :: model_eqns !< Multicomponent flow model + integer :: num_fluids !< Number of different fluids present in the flow + logical :: relax !< phase change + integer :: relax_model !< Phase change relaxation model + logical :: mpp_lim !< Maximum volume fraction limiter + integer :: sys_size !< Number of unknowns in the system of equations + integer :: recon_type !< Which type of reconstruction to use + integer :: weno_order !< Order of accuracy for the WENO reconstruction + integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction + logical :: mixture_err !< Mixture error limiter + logical :: alt_soundspeed !< Alternate sound speed + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity for RMHD + logical :: hypoelasticity !< Turn hypoelasticity on + logical :: hyperelasticity !< Turn hyperelasticity on + logical :: elasticity !< elasticity modeling, true for hyper or hypo + integer :: b_size !< Number of components in the b tensor + integer :: tensor_size !< Number of components in the nonsymmetric tensor + logical :: cont_damage !< Continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD + logical :: igr !< enable IGR + integer :: igr_order !< IGR reconstruction order logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling !> @} @@ -123,24 +121,24 @@ module m_global_parameters !> @name Annotations of the structure, i.e. the organization, of the state vectors !> @{ - type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. - type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of energy equation - integer :: n_idx !< Index of number density - integer :: beta_idx !< Index of lagrange bubbles beta - type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. - type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. - type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: alf_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. - type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. - type(int_bounds_info) :: stress_idx !< Indices of elastic stresses - type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: c_idx !< Index of color function - type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. + type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. + integer :: E_idx !< Index of energy equation + integer :: n_idx !< Index of number density + integer :: beta_idx !< Index of lagrange bubbles beta + type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. + type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. + type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: alf_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. + type(int_bounds_info) :: stress_idx !< Indices of elastic stresses + type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. + integer :: c_idx !< Index of color function + type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD !> @} ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). @@ -167,10 +165,10 @@ module m_global_parameters !! Indices of shear stress components to reflect for boundary conditions. !! Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, [indices]) - logical :: parallel_io !< Format of the data files + logical :: parallel_io !< Format of the data files logical :: sim_data logical :: file_per_process !< output format - integer, allocatable, dimension(:) :: proc_coords !< + integer, allocatable, dimension(:) :: proc_coords !< !! Processor coordinates in MPI_CART_COMM integer, allocatable, dimension(:) :: start_idx !< @@ -204,11 +202,11 @@ module m_global_parameters ! Formatted Database File(s) Structure Parameters - integer :: format !< Format of the database file(s) - integer :: precision !< Floating point precision of the database file(s) - logical :: down_sample !< down sampling of the database file(s) - logical :: output_partial_domain !< Specify portion of domain to output for post-processing - type(bounds_info) :: x_output, y_output, z_output !< Portion of domain to output for post-processing + integer :: format !< Format of the database file(s) + integer :: precision !< Floating point precision of the database file(s) + logical :: down_sample !< down sampling of the database file(s) + logical :: output_partial_domain !< Specify portion of domain to output for post-processing + type(bounds_info) :: x_output, y_output, z_output !< Portion of domain to output for post-processing type(int_bounds_info) :: x_output_idx, y_output_idx, z_output_idx !< Indices of domain to output for post-processing !> @name Size of the ghost zone layer in the x-, y- and z-coordinate directions. The definition of the ghost zone layers is only @@ -338,7 +336,7 @@ module m_global_parameters logical :: bubbles_lagrange !> @} - real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) + real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) real(wp) :: wall_time, wall_time_avg !< Wall time measurements contains @@ -535,6 +533,7 @@ contains ! MHD Bx0 = dflt_real end subroutine s_assign_default_values_to_user_inputs + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_global_parameters_module integer :: i, j, fac @@ -945,6 +944,7 @@ contains grid_geometry = 3 end if end subroutine s_initialize_global_parameters_module + !> Subroutine to initialize parallel infrastructure impure subroutine s_initialize_parallel_io #ifdef MFC_MPI @@ -979,6 +979,7 @@ contains allocate (start_idx(1:num_dims)) #endif end subroutine s_initialize_parallel_io + !> Deallocation procedures for the module impure subroutine s_finalize_global_parameters_module integer :: i diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index fc104b799f..674e34ea05 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -9,11 +9,8 @@ module m_mpi_proxy #endif use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_common - use ieee_arithmetic implicit none @@ -30,7 +27,7 @@ contains impure subroutine s_initialize_mpi_proxy_module #ifdef MFC_MPI - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors ! Allocating and configuring the receive counts and the displacement @@ -57,11 +54,12 @@ contains end if #endif end subroutine s_initialize_mpi_proxy_module + !> Since only processor with rank 0 is in charge of reading and checking the consistency of the user provided inputs, these are !! not available to the remaining processors. This subroutine is then in charge of broadcasting the required information. impure subroutine s_mpi_bcast_user_inputs #ifdef MFC_MPI - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors ! Logistics @@ -135,6 +133,7 @@ contains call MPI_BCAST(schlieren_alpha(1), num_fluids_max, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_bcast_user_inputs + !> This subroutine gathers the Silo database metadata for the spatial extents in order to boost the performance of the !! multidimensional visualization. ! ! @param spatial_extents Spatial extents for each processor's sub-domain. First dimension corresponds to the minimum and @@ -151,51 +150,51 @@ contains if (grid_geometry == 3) then ! Minimum spatial extent in the r-direction call MPI_GATHERV(minval(y_cb), 1, mpi_p, spatial_extents(1, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Minimum spatial extent in the theta-direction call MPI_GATHERV(minval(z_cb), 1, mpi_p, spatial_extents(2, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Minimum spatial extent in the z-direction call MPI_GATHERV(minval(x_cb), 1, mpi_p, spatial_extents(3, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the r-direction call MPI_GATHERV(maxval(y_cb), 1, mpi_p, spatial_extents(4, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the theta-direction call MPI_GATHERV(maxval(z_cb), 1, mpi_p, spatial_extents(5, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the z-direction call MPI_GATHERV(maxval(x_cb), 1, mpi_p, spatial_extents(6, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) else ! Minimum spatial extent in the x-direction call MPI_GATHERV(minval(x_cb), 1, mpi_p, spatial_extents(1, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Minimum spatial extent in the y-direction call MPI_GATHERV(minval(y_cb), 1, mpi_p, spatial_extents(2, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Minimum spatial extent in the z-direction call MPI_GATHERV(minval(z_cb), 1, mpi_p, spatial_extents(3, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the x-direction call MPI_GATHERV(maxval(x_cb), 1, mpi_p, spatial_extents(4, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the y-direction call MPI_GATHERV(maxval(y_cb), 1, mpi_p, spatial_extents(5, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the z-direction call MPI_GATHERV(maxval(z_cb), 1, mpi_p, spatial_extents(6, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) end if ! Simulation is 2D else if (n > 0) then @@ -226,6 +225,7 @@ contains end if #endif end subroutine s_mpi_gather_spatial_extents + !> This subroutine collects the sub-domain cell-boundary or cell-center locations data from all of the processors and puts back !! together the grid of the entire computational domain on the rank 0 processor. This is only done for 1D simulations. impure subroutine s_mpi_defragment_1d_grid_variable @@ -245,6 +245,7 @@ contains end if #endif end subroutine s_mpi_defragment_1d_grid_variable + !> This subroutine gathers the Silo database metadata for the flow variable's extents as to boost performance of the !! multidimensional visualization. !! @param q_sf Flow variable defined on a single computational sub-domain @@ -279,6 +280,7 @@ contains end if #endif end subroutine s_mpi_gather_data_extents + !> This subroutine gathers the sub-domain flow variable data from all of the processors and puts it back together for the entire !! computational domain on the rank 0 processor. This is only done for 1D simulations. !! @param q_sf Flow variable defined on a single computational sub-domain @@ -296,6 +298,7 @@ contains call MPI_GATHERV(q_sf(0), m + 1, mpi_p, q_root_sf(0), recvcounts, displs, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_defragment_1d_flow_variable + !> Deallocation procedures for the module impure subroutine s_finalize_mpi_proxy_module #ifdef MFC_MPI diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index c61abed4a3..73bf851ab9 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -12,15 +12,10 @@ module m_start_up use, intrinsic :: iso_c_binding use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_mpi_common !< Common MPI subroutines - use m_boundary_common !< Common boundary conditions subroutines - use m_variables_conversion !< Subroutines to change the state variables from !! one form to another @@ -33,17 +28,11 @@ module m_start_up use m_derived_variables !< Procedures used to compute quantities derived !! from the conservative and primitive variables use m_helper - use m_compile_specific - use m_checker_common - use m_checker - use m_thermochem, only: num_species, species_names - use m_finite_differences - use m_chemistry #ifdef MFC_MPI @@ -140,6 +129,7 @@ contains call s_mpi_abort('File post_process.inp is missing. Exiting.') end if end subroutine s_read_input_file + !> Checking that the user inputs make sense, i.e. that the individual choices are compatible with the code's options and that !! the combination of these choices results into a valid configuration for the post-process impure subroutine s_check_input_file @@ -164,13 +154,14 @@ contains call s_check_inputs_common() call s_check_inputs() end subroutine s_check_input_file + !> @brief Load grid and conservative data for a time step, fill ghost-cell buffers, and convert to primitive variables. impure subroutine s_perform_time_step(t_step) integer, intent(inout) :: t_step if (proc_rank == 0) then if (cfl_dt) then print '(" [", I3, "%] Saving ", I8, " of ", I0, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', & - & int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), t_step, n_save, wall_time_avg, wall_time + & int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), t_step, n_save, wall_time_avg, wall_time else print '(" [", I3, "%] Saving ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), (t_step - t_step_start)/t_step_save + 1, (t_step_stop - t_step_start)/t_step_save + 1, t_step, wall_time_avg, wall_time end if @@ -191,6 +182,7 @@ contains ! Converting the conservative variables to the primitive ones call s_convert_conservative_to_primitive_variables(q_cons_vf, q_T_sf, q_prim_vf, idwbuff) end subroutine s_perform_time_step + !> @brief Derive requested flow quantities from primitive variables and write them to the formatted database files. impure subroutine s_save_data(t_step, varname, pres, c, H) integer, intent(inout) :: t_step @@ -198,9 +190,9 @@ contains real(wp), intent(inout) :: pres, c, H real(wp) :: theta1, theta2 real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, & - & -offset_z%beg:p + offset_z%end) :: liutex_mag + & -offset_z%beg:p + offset_z%end) :: liutex_mag real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, & - & 3) :: liutex_axis + & 3) :: liutex_axis integer :: i, j, k, l, kx, ky, kz, kf, j_glb, k_glb, l_glb real(wp) :: En_tot character(50) :: filename, dirname @@ -394,7 +386,7 @@ contains do k = 0, n do j = 0, m data_cmplx(j + 1, k + 1, l + 1) = cmplx(q_cons_vf(mom_idx%beg + 1)%sf(j, k, l)/q_cons_vf(1)%sf(j, k, l), & - & 0._wp) + & 0._wp) end do end do end do @@ -407,7 +399,7 @@ contains do k = 0, n do j = 0, m data_cmplx(j + 1, k + 1, l + 1) = cmplx(q_cons_vf(mom_idx%beg + 2)%sf(j, k, l)/q_cons_vf(1)%sf(j, k, l), & - & 0._wp) + & 0._wp) end do end do end do @@ -644,7 +636,7 @@ contains H = ((gamma_sf(i, j, k) + 1._wp)*pres + pi_inf_sf(i, j, k) + qv_sf(i, j, k))/rho_sf(i, j, k) 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)) + & 0._wp, 0._wp, c, qv_sf(i, j, k)) q_sf(i, j, k) = c end do @@ -671,7 +663,7 @@ contains 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)) + & -offset_z%beg:p + offset_z%end)) varname = 'ib_markers' call s_write_variable_to_formatted_database_file(varname, t_step) end if @@ -786,7 +778,7 @@ 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) + & -offset_z%beg:p + offset_z%end) write (varname, '(A)') 'voidFraction' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -803,6 +795,7 @@ contains ! Closing the formatted database file call s_close_formatted_database_file() end subroutine s_save_data + !> @brief Transpose 3-D complex data from x-pencil to y-pencil layout via MPI_Alltoall. subroutine s_mpi_transpose_x2y complex(c_double_complex), allocatable :: sendbuf(:), recvbuf(:) @@ -819,21 +812,21 @@ contains do k = 1, Nyloc do j = 1, Nxloc sendbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + dest_rank*Nxloc*Nyloc*Nzloc) = data_cmplx(j & - & + dest_rank*Nxloc, k, l) + & + dest_rank*Nxloc, k, l) end do end do end do end do call MPI_Alltoall(sendbuf, Nxloc*Nyloc*Nzloc, MPI_C_DOUBLE_COMPLEX, recvbuf, Nxloc*Nyloc*Nzloc, MPI_C_DOUBLE_COMPLEX, & - & MPI_COMM_CART12, ierr) + & MPI_COMM_CART12, ierr) do src_rank = 0, num_procs_y - 1 do l = 1, Nzloc do k = 1, Nyloc do j = 1, Nxloc data_cmplx_y(j, k + src_rank*Nyloc, & - & l) = recvbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + src_rank*Nxloc*Nyloc*Nzloc) + & l) = recvbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + src_rank*Nxloc*Nyloc*Nzloc) end do end do end do @@ -843,6 +836,7 @@ contains deallocate (recvbuf) #endif end subroutine s_mpi_transpose_x2y + !> @brief Transpose 3-D complex data from y-pencil to z-pencil layout via MPI_Alltoall. subroutine s_mpi_transpose_y2z complex(c_double_complex), allocatable :: sendbuf(:), recvbuf(:) @@ -859,22 +853,22 @@ contains do j = 1, Nxloc do k = 1, Nyloc2 sendbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) + dest_rank*Nyloc2*Nxloc*Nzloc) = data_cmplx_y(j, & - & k + dest_rank*Nyloc2, l) + & k + dest_rank*Nyloc2, l) end do end do end do end do call MPI_Alltoall(sendbuf, Nyloc2*Nxloc*Nzloc, MPI_C_DOUBLE_COMPLEX, recvbuf, Nyloc2*Nxloc*Nzloc, MPI_C_DOUBLE_COMPLEX, & - & MPI_COMM_CART13, ierr) + & MPI_COMM_CART13, ierr) do src_rank = 0, num_procs_z - 1 do l = 1, Nzloc do j = 1, Nxloc do k = 1, Nyloc2 data_cmplx_z(j, k, & - & l + src_rank*Nzloc) = recvbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) & - & + src_rank*Nyloc2*Nxloc*Nzloc) + & l + src_rank*Nzloc) = recvbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) & + & + src_rank*Nyloc2*Nxloc*Nzloc) end do end do end do @@ -884,6 +878,7 @@ contains deallocate (recvbuf) #endif end subroutine s_mpi_transpose_y2z + !> @brief Initialize all post-process sub-modules, set up I/O pointers, and prepare FFTW plans and MPI communicators. impure subroutine s_initialize_modules ! Computation of parameters, allocation procedures, and/or any other tasks @@ -943,24 +938,24 @@ contains onembed(1) = Nx fwd_plan_x = fftw_plan_many_dft(1, size_n, Nyloc*Nzloc, data_in, inembed, 1, Nx, data_out, onembed, 1, Nx, & - & FFTW_FORWARD, FFTW_MEASURE) + & FFTW_FORWARD, FFTW_MEASURE) size_n(1) = Ny inembed(1) = Ny onembed(1) = Ny fwd_plan_y = fftw_plan_many_dft(1, size_n, Nxloc*Nzloc, data_out, inembed, 1, Ny, data_in, onembed, 1, Ny, & - & FFTW_FORWARD, FFTW_MEASURE) + & FFTW_FORWARD, FFTW_MEASURE) size_n(1) = Nz inembed(1) = Nz onembed(1) = Nz fwd_plan_z = fftw_plan_many_dft(1, size_n, Nxloc*Nyloc2, data_in, inembed, 1, Nz, data_out, onembed, 1, Nz, & - & FFTW_FORWARD, FFTW_MEASURE) + & FFTW_FORWARD, FFTW_MEASURE) call MPI_CART_CREATE(MPI_COMM_WORLD, 3, (/num_procs_x, num_procs_y, num_procs_z/), (/.true., .true., .true./), & - & .false., MPI_COMM_CART, ierr) + & .false., MPI_COMM_CART, ierr) call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, cart3d_coords, ierr) call MPI_Cart_SUB(MPI_COMM_CART, (/.true., .true., .false./), MPI_COMM_CART12, ierr) @@ -973,6 +968,7 @@ contains end if #endif end subroutine s_initialize_modules + !> @brief Perform a distributed forward 3-D FFT using pencil decomposition with FFTW and MPI transposes. subroutine s_mpi_FFT_fwd integer :: j, k, l @@ -1038,6 +1034,7 @@ contains end do #endif end subroutine s_mpi_FFT_fwd + !> @brief Set up the MPI environment, read and broadcast user inputs, and decompose the computational domain. impure subroutine s_initialize_mpi_domain num_dims = 1 + min(1, n) + min(1, p) @@ -1065,6 +1062,7 @@ contains call s_mpi_decompose_computational_domain() call s_check_inputs_fft() end subroutine s_initialize_mpi_domain + !> @brief Destroy FFTW plans, free MPI communicators, and finalize all post-process sub-modules. impure subroutine s_finalize_modules ! Disassociate pointers for serial and parallel I/O diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index 854b5475f4..a8ae0c0092 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -12,7 +12,7 @@ program p_main implicit none - integer :: t_step !< Iterator for the main time-stepping loop + integer :: t_step !< Iterator for the main time-stepping loop character(LEN=name_len) :: varname !< !! Generic storage for the name(s) of the flow variable(s) that will be added !! to the formatted database file(s) diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index bfe1bc32d3..39b2a53164 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -8,13 +8,9 @@ !> @brief Assigns initial primitive variables to computational cells based on patch geometry module m_assign_variables use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters for the code - use m_variables_conversion ! Subroutines to change the state variables from - use m_helper_basic !< Functions to compare floating point numbers - use m_thermochem, only: num_species, gas_constant, get_mixture_molecular_weight implicit none @@ -75,6 +71,7 @@ contains s_assign_patch_primitive_variables => s_assign_patch_species_primitive_variables end if end subroutine s_initialize_assign_variables_module + !> This subroutine assigns the mixture primitive variables of the patch designated by the patch_id, to the cell that is !! designated by the indexes (j,k,l). In addition, the variable bookkeeping the patch identities in the entire domain is updated !! with the new assignment. Note that if the smoothing of the patch's boundaries is employed, the ensuing primitive variables in @@ -115,8 +112,8 @@ contains ! Velocity do i = 1, E_idx - mom_idx%beg q_prim_vf(i + 1)%sf(j, k, l) = 1._wp/q_prim_vf(1)%sf(j, k, & - & l)*(eta*patch_icpp(patch_id)%rho*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*patch_icpp(smooth_patch_id) & - & %rho*patch_icpp(smooth_patch_id)%vel(i)) + & l)*(eta*patch_icpp(patch_id)%rho*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*patch_icpp(smooth_patch_id) & + & %rho*patch_icpp(smooth_patch_id)%vel(i)) end do ! Specific heat ratio function @@ -124,8 +121,8 @@ contains ! Pressure q_prim_vf(E_idx)%sf(j, k, l) = 1._wp/q_prim_vf(gamma_idx)%sf(j, k, & - & l)*(eta*patch_icpp(patch_id)%gamma*patch_icpp(patch_id)%pres + (1._wp - eta)*patch_icpp(smooth_patch_id) & - & %gamma*patch_icpp(smooth_patch_id)%pres) + & l)*(eta*patch_icpp(patch_id)%gamma*patch_icpp(patch_id)%pres + (1._wp - eta)*patch_icpp(smooth_patch_id) & + & %gamma*patch_icpp(smooth_patch_id)%pres) ! Liquid stiffness function q_prim_vf(pi_inf_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%pi_inf + (1._wp - eta)*patch_icpp(smooth_patch_id)%pi_inf @@ -156,6 +153,7 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < 1.e-16_wp) patch_id_fp(j, k, l) = patch_id end subroutine s_assign_patch_mixture_primitive_variables + !> @brief Applies a stable pressure perturbation following Ando's method for bubble-laden flows. !! @param j the x-dir node index !! @param k the y-dir node index @@ -181,7 +179,7 @@ contains if (qbmm) then do i = 1, nb q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, & - & l)*((p0 - bub_pp%pv)/(q_prim_vf(E_idx)%sf(j, k, l)*p0 - bub_pp%pv))**(1._wp/3._wp) + & l)*((p0 - bub_pp%pv)/(q_prim_vf(E_idx)%sf(j, k, l)*p0 - bub_pp%pv))**(1._wp/3._wp) end do end if @@ -228,6 +226,7 @@ contains q_prim_vf(alf_idx)%sf(j, k, l) = vfH end subroutine s_perturb_primitive + !> This subroutine assigns the species primitive variables. This follows s_assign_patch_species_primitive_variables with !! adaptation for ensemble-averaged bubble modeling !! @param patch_id the patch identifier @@ -253,11 +252,11 @@ contains ! Density, the specific heat ratio function and the liquid stiffness ! function, respectively, obtained from the combination of primitive ! variables of the current and smoothing patches - real(wp) :: rho !< density + real(wp) :: rho !< density real(wp) :: gamma - real(wp) :: lit_gamma !< specific heat ratio - real(wp) :: pi_inf !< stiffness from SEOS - real(wp) :: qv !< reference energy from SEOS + real(wp) :: lit_gamma !< specific heat ratio + real(wp) :: pi_inf !< stiffness from SEOS + real(wp) :: qv !< reference energy from SEOS real(wp) :: orig_rho real(wp) :: orig_gamma real(wp) :: orig_pi_inf @@ -328,7 +327,7 @@ contains ! Density and the specific heat ratio and liquid stiffness functions ! call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, patch_icpp(patch_id)%rho, patch_icpp(patch_id)%gamma, & - & patch_icpp(patch_id)%pi_inf, patch_icpp(patch_id)%qv) + & patch_icpp(patch_id)%pi_inf, patch_icpp(patch_id)%qv) ! Computing Mixture Variables of Smoothing Patch @@ -403,8 +402,7 @@ contains ! Density and the specific heat ratio and liquid stiffness functions ! call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, patch_icpp(smooth_patch_id)%rho, & - & patch_icpp(smooth_patch_id)%gamma, patch_icpp(smooth_patch_id)%pi_inf, & - & patch_icpp(smooth_patch_id)%qv) + & patch_icpp(smooth_patch_id)%gamma, patch_icpp(smooth_patch_id)%pi_inf, patch_icpp(smooth_patch_id)%qv) ! Pressure q_prim_vf(E_idx)%sf(j, k, l) = (eta*patch_icpp(patch_id)%pres + (1._wp - eta)*orig_prim_vf(E_idx)) @@ -431,7 +429,7 @@ contains if (elasticity) then do i = 1, (stress_idx%end - stress_idx%beg) + 1 q_prim_vf(i + stress_idx%beg - 1)%sf(j, k, & - & l) = (eta*patch_icpp(patch_id)%tau_e(i) + (1._wp - eta)*orig_prim_vf(i + stress_idx%beg - 1)) + & l) = (eta*patch_icpp(patch_id)%tau_e(i) + (1._wp - eta)*orig_prim_vf(i + stress_idx%beg - 1)) end do end if @@ -484,7 +482,7 @@ contains ! \rho = (( p_l + pi_inf)/( p_ref + pi_inf))**(1/little_gam) * rhoref(1-alf) q_prim_vf(1)%sf(j, k, l) = (((q_prim_vf(E_idx)%sf(j, k, & - & l) + pi_inf)/(pref + pi_inf))**(1/lit_gamma))*rhoref*(1 - q_prim_vf(alf_idx)%sf(j, k, l)) + & l) + pi_inf)/(pref + pi_inf))**(1/lit_gamma))*rhoref*(1 - q_prim_vf(alf_idx)%sf(j, k, l)) end if ! Density and the specific heat ratio and liquid stiffness functions @@ -494,7 +492,7 @@ contains ! Velocity do i = 1, E_idx - mom_idx%beg q_prim_vf(i + cont_idx%end)%sf(j, k, & - & l) = (eta*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*orig_prim_vf(i + cont_idx%end)) + & l) = (eta*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*orig_prim_vf(i + cont_idx%end)) end do ! Species Concentrations @@ -525,8 +523,8 @@ contains ! Set streamwise velocity to hyperbolic tangent function of y if (mixlayer_vel_profile) then q_prim_vf(1 + cont_idx%end)%sf(j, k, & - & l) = (eta*patch_icpp(patch_id)%vel(1)*tanh(y_cc(k)*mixlayer_vel_coef) + (1._wp - eta)*orig_prim_vf(1 & - & + cont_idx%end)) + & l) = (eta*patch_icpp(patch_id)%vel(1)*tanh(y_cc(k)*mixlayer_vel_coef) + (1._wp - eta)*orig_prim_vf(1 & + & + cont_idx%end)) end if ! Set partial pressures to mixture pressure for the 6-eqn model @@ -619,6 +617,7 @@ contains ! print *, (bub_idx%fullmom(i, 1, 0), i = 1, nb) ! end if end subroutine s_assign_patch_species_primitive_variables + !> @brief Nullifies the patch primitive variable assignment procedure pointer. impure subroutine s_finalize_assign_variables_module ! Nullifying procedure pointer to the subroutine assigning either diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index 90fa445b2a..21dc3c99fe 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -5,15 +5,12 @@ !> @brief Applies spatially varying boundary condition patches along domain edges and faces module m_boundary_conditions use m_derived_types - use m_global_parameters #ifdef MFC_MPI use mpi #endif use m_delay_file_access - use m_compile_specific - use m_boundary_common implicit none @@ -71,6 +68,7 @@ contains #:endfor end if end subroutine s_line_segment_bc + !> @brief Applies a circular boundary condition patch on a domain face in 3D. impure subroutine s_circle_bc(patch_id, bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type @@ -127,6 +125,7 @@ contains #:endfor end if end subroutine s_circle_bc + !> @brief Applies a rectangular boundary condition patch on a domain face in 3D. impure subroutine s_rectangle_bc(patch_id, bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type @@ -207,6 +206,7 @@ contains #:endfor end if end subroutine s_rectangle_bc + !> @brief Iterates over all boundary condition patches and dispatches them by geometry type. impure subroutine s_apply_boundary_patches(q_prim_vf, bc_type) type(scalar_field), dimension(sys_size) :: q_prim_vf diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index 53a7954cb5..8a8603070e 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -8,11 +8,8 @@ module m_check_ib_patches use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Procedures to write the grid data and the !! conservative variables to files @@ -21,9 +18,7 @@ module m_check_ib_patches #endif use m_compile_specific - use m_helper_basic !< Functions to compare floating point numbers - use m_helper implicit none @@ -42,8 +37,7 @@ contains if (i <= num_ibs) then ! call s_check_patch_geometry(i) call s_int_to_str(i, iStr) - @:PROHIBIT(patch_ib(i)%geometry == dflt_int, "IB patch undefined. & - patch_ib("//trim(iStr)//")%geometry must be set.") + @:PROHIBIT(patch_ib(i)%geometry == dflt_int, "IB patch undefined. patch_ib("//trim(iStr)//")%geometry must be set.") ! Constraints on the geometric initial condition patch parameters if (patch_ib(i)%geometry == 2) then @@ -66,7 +60,7 @@ contains call s_check_ellipse_ib_patch_geometry(i) else call s_prohibit_abort("Invalid IB patch", & - & "patch_ib(" // trim(iStr) // ")%geometry must be " // "2-4, 8-10, 11 or 12.") + & "patch_ib(" // trim(iStr) // ")%geometry must be " // "2-4, 8-10, 11 or 12.") end if else @:PROHIBIT(patch_ib(i)%geometry /= dflt_int, "Inactive IB patch defined. "// "patch_ib("//trim(iStr)//")%geometry must not be set for inactive patches.") @@ -74,6 +68,7 @@ contains end if end do end subroutine s_check_ib_patches + !> This subroutine verifies that the geometric parameters of the circle patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_circle_ib_patch_geometry(patch_id) @@ -83,6 +78,7 @@ contains @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%radius <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in circle IB patch '//trim(iStr)) end subroutine s_check_circle_ib_patch_geometry + !> This subroutine verifies that the geometric parameters of the ellipse patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_ellipse_ib_patch_geometry(patch_id) @@ -92,6 +88,7 @@ contains @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in ellipse IB patch '//trim(iStr)) end subroutine s_check_ellipse_ib_patch_geometry + !> This subroutine verifies that the geometric parameters of the airfoil patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_airfoil_ib_patch_geometry(patch_id) @@ -101,6 +98,7 @@ contains @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id)%p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in airfoil IB patch '//trim(iStr)) end subroutine s_check_airfoil_ib_patch_geometry + !> This subroutine verifies that the geometric parameters of the 3d airfoil patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_3d_airfoil_ib_patch_geometry(patch_id) @@ -110,6 +108,7 @@ contains @:PROHIBIT(n == 0 .or. p == 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id)%p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. f_is_default(patch_ib(patch_id)%length_z), 'in 3d airfoil IB patch '//trim(iStr)) end subroutine s_check_3d_airfoil_ib_patch_geometry + !> This subroutine verifies that the geometric parameters of the rectangle patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_rectangle_ib_patch_geometry(patch_id) @@ -119,6 +118,7 @@ contains @:PROHIBIT(n == 0 .or. p > 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp, 'in rectangle IB patch '//trim(iStr)) end subroutine s_check_rectangle_ib_patch_geometry + !> This subroutine verifies that the geometric parameters of the sphere patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_sphere_ib_patch_geometry(patch_id) @@ -128,6 +128,7 @@ contains @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%radius <= 0._wp, 'in sphere IB patch '//trim(iStr)) end subroutine s_check_sphere_ib_patch_geometry + !> This subroutine verifies that the geometric parameters of the cuboid patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_cuboid_ib_patch_geometry(patch_id) @@ -137,6 +138,7 @@ contains @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. patch_ib(patch_id)%length_z <= 0._wp, 'in cuboid IB patch '//trim(iStr)) end subroutine s_check_cuboid_ib_patch_geometry + !> This subroutine verifies that the geometric parameters of the cylinder patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_cylinder_ib_patch_geometry(patch_id) @@ -148,6 +150,7 @@ contains @:PROHIBIT( (patch_ib(patch_id)%length_x > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_y)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id)%length_y > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id)%length_z > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_y)))), 'in cylinder IB patch '//trim(iStr)) end subroutine s_check_cylinder_ib_patch_geometry + !> This subroutine verifies that the geometric parameters of the model patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_model_ib_patch_geometry(patch_id) @@ -159,6 +162,7 @@ contains @:PROHIBIT(patch_ib(patch_id)%model_scale(1) <= 0._wp .or. patch_ib(patch_id)%model_scale(2) <= 0._wp .or. patch_ib(patch_id)%model_scale(3) <= 0._wp, 'Negative scale in model IB patch '//trim(iStr)) end subroutine s_check_model_ib_patch_geometry + !!> This subroutine verifies that the geometric parameters of !! the inactive patch remain unaltered by the user inputs. !! @param patch_id Patch identifier diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 67f9b978fd..5e50457bc8 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -11,11 +11,8 @@ module m_check_patches ! Dependencies use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Procedures to write the grid data and the !! conservative variables to files @@ -24,9 +21,7 @@ module m_check_patches #endif use m_compile_specific - use m_helper_basic !< Functions to compare floating point numbers - use m_helper implicit none @@ -83,7 +78,7 @@ contains call s_check_model_geometry(i) else call s_prohibit_abort("Invalid patch geometry number", & - & "patch_icpp(" // trim(iStr) // ")%geometry " // "must be between 1 and 21") + & "patch_icpp(" // trim(iStr) // ")%geometry " // "must be between 1 and 21") end if else @:PROHIBIT(patch_icpp(i)%geometry /= dflt_int, "Inactive patch defined. "// "patch_icpp("//trim(iStr)//")%geometry not be set for inactive patches. "// "Patch "//trim(iStr)//" is inactive as the number of patches is "//trim(num_patches_str)) @@ -121,6 +116,7 @@ contains end if end do end subroutine s_check_patches + !> This subroutine checks the line segment patch input !! @param patch_id Patch identifier impure subroutine s_check_line_segment_patch_geometry(patch_id) @@ -132,6 +128,7 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Line segment patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(cyl_coord, "Line segment patch "//trim(iStr)//": cyl_coord is not supported") end subroutine s_check_line_segment_patch_geometry + !> This subroutine checks the circle patch input !! @param patch_id Patch identifier impure subroutine s_check_circle_patch_geometry(patch_id) @@ -144,6 +141,7 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Circle patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Circle patch "//trim(iStr)//": y_centroid must be set") end subroutine s_check_circle_patch_geometry + !> This subroutine checks the rectangle patch input !! @param patch_id Patch identifier impure subroutine s_check_rectangle_patch_geometry(patch_id) @@ -157,6 +155,7 @@ contains @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Rectangle patch "//trim(iStr)//": length_x must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Rectangle patch "//trim(iStr)//": length_y must be greater than zero") end subroutine s_check_rectangle_patch_geometry + !> This subroutine checks the line sweep patch input !! @param patch_id Patch identifier impure subroutine s_check_line_sweep_patch_geometry(patch_id) @@ -171,6 +170,7 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(2)), "Line sweep patch "//trim(iStr)//": normal(2) must be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%normal(3)), "Line sweep patch "//trim(iStr)//": normal(3) must not be set") end subroutine s_check_line_sweep_patch_geometry + !> This subroutine checks the ellipse patch input !! @param patch_id Patch identifier impure subroutine s_check_ellipse_patch_geometry(patch_id) @@ -185,6 +185,7 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0._wp, "Ellipse patch "//trim(iStr)//": radii(2) must be greater than zero") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(3)), "Ellipse patch "//trim(iStr)//": radii(3) must not be set") end subroutine s_check_ellipse_patch_geometry + !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_2D_TaylorGreen_vortex_patch_geometry(patch_id) @@ -199,6 +200,7 @@ contains @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Taylor Green vortex patch "//trim(iStr)//": length_y must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%vel(2) <= 0._wp, "Taylor Green vortex patch "//trim(iStr)//": vel(2) must be greater than zero") end subroutine s_check_2D_TaylorGreen_vortex_patch_geometry + !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_sphere_patch_geometry(patch_id) @@ -211,6 +213,7 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Sphere patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Sphere patch "//trim(iStr)//": z_centroid must be set") end subroutine s_check_sphere_patch_geometry + impure subroutine s_check_2d_modal_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -222,6 +225,7 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "2D modal patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "2D modal patch "//trim(iStr)//": y_centroid must be set") end subroutine s_check_2d_modal_patch_geometry + impure subroutine s_check_3d_spherical_harmonic_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -233,6 +237,7 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Spherical harmonic patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Spherical harmonic patch "//trim(iStr)//": z_centroid must be set") end subroutine s_check_3d_spherical_harmonic_patch_geometry + !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_cuboid_patch_geometry(patch_id) @@ -248,6 +253,7 @@ contains @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Cuboid patch "//trim(iStr)//": length_y must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_z <= 0._wp, "Cuboid patch "//trim(iStr)//": length_z must be greater than zero") end subroutine s_check_cuboid_patch_geometry + !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_cylinder_patch_geometry(patch_id) @@ -267,6 +273,7 @@ contains ! Ensure the defined length is positive @:PROHIBIT( (.not. f_is_default(patch_icpp(patch_id)%length_x) .and. patch_icpp(patch_id)%length_x <= 0._wp) .or. (.not. f_is_default(patch_icpp(patch_id)%length_y) .and. patch_icpp(patch_id)%length_y <= 0._wp) .or. (.not. f_is_default(patch_icpp(patch_id)%length_z) .and. patch_icpp(patch_id)%length_z <= 0._wp), "Cylinder patch "//trim(iStr)//": The defined length_{} must be greater than zero") end subroutine s_check_cylinder_patch_geometry + !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_plane_sweep_patch_geometry(patch_id) @@ -282,6 +289,7 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(2)), "Plane sweep patch "//trim(iStr)//": normal(2) must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(3)), "Plane sweep patch "//trim(iStr)//": normal(3) must be set") end subroutine s_check_plane_sweep_patch_geometry + !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_ellipsoid_patch_geometry(patch_id) @@ -296,6 +304,7 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(2) must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%radii(3) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(3) must be greater than zero") end subroutine s_check_ellipsoid_patch_geometry + !!> This subroutine verifies that the geometric parameters of !! the inactive patch remain unaltered by the user inputs. !! @param patch_id Patch identifier @@ -319,6 +328,7 @@ contains @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(2)), "Inactive patch "//trim(iStr)//": radii(2) must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(3)), "Inactive patch "//trim(iStr)//": radii(3) must not be set") end subroutine s_check_inactive_patch_geometry + !> This subroutine verifies the active patch's right to overwrite the preceding patches !! @param patch_id Patch identifier impure subroutine s_check_active_patch_alteration_rights(patch_id) @@ -328,6 +338,7 @@ contains @:PROHIBIT(.not. patch_icpp(patch_id)%alter_patch(0), "Patch "//trim(iStr)//": alter_patch(0) must be true") @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(patch_id:)), "Patch "//trim(iStr)// ":alter_patch(i) must be false for i >= "//trim(iStr)//". Only preceding patches can be altered") end subroutine s_check_active_patch_alteration_rights + !> This subroutine verifies that inactive patches cannot overwrite other patches !! @param patch_id Patch identifier impure subroutine s_check_inactive_patch_alteration_rights(patch_id) @@ -338,6 +349,7 @@ contains @:PROHIBIT(.not. patch_icpp(patch_id)%alter_patch(0), "Inactive patch "//trim(iStr)//": cannot have alter_patch(0) altered") @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(1:)), "Inactive patch "//trim(iStr)//": cannot have any alter_patch(i) enabled") end subroutine s_check_inactive_patch_alteration_rights + !> This subroutine checks the smoothing parameters !! @param patch_id Patch identifier impure subroutine s_check_supported_patch_smoothing(patch_id) @@ -353,6 +365,7 @@ contains @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), "Smoothen disabled. Patch "//trim(iStr)//": smooth_coeff must not be set") end if end subroutine s_check_supported_patch_smoothing + !> This subroutine verifies that inactive patches cannot be smoothed !! @param patch_id Patch identifier impure subroutine s_check_unsupported_patch_smoothing(patch_id) @@ -364,6 +377,7 @@ contains @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, "Inactive patch "//trim(iStr)//": smooth_patch_id must be equal to patch_id") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), "Inactive patch "//trim(iStr)//": smooth_coeff must not be set") end subroutine s_check_unsupported_patch_smoothing + !> This subroutine checks the primitive variables !! @param patch_id Patch identifier impure subroutine s_check_active_patch_primitive_variables(patch_id) @@ -404,6 +418,7 @@ contains !@:ASSERT(any(patch_icpp(patch_id)%Y(1:num_species) > verysmall), "Patch " // trim(iStr) // ".") end if end subroutine s_check_active_patch_primitive_variables + !> This subroutine verifies that the primitive variables associated with the given inactive patch remain unaltered by the user !! inputs. !! @param patch_id Patch identifier @@ -419,6 +434,7 @@ contains @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%gamma), "Inactive patch "//trim(iStr)//": gamma must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%pi_inf), "Inactive patch "//trim(iStr)//": pi_inf must not be set") end subroutine s_check_inactive_patch_primitive_variables + !> @brief Verifies that the model file referenced by the given patch exists on disk. impure subroutine s_check_model_geometry(patch_id) integer, intent(in) :: patch_id diff --git a/src/pre_process/m_checker.fpp b/src/pre_process/m_checker.fpp index bde17ff99b..369dd88eb0 100644 --- a/src/pre_process/m_checker.fpp +++ b/src/pre_process/m_checker.fpp @@ -7,11 +7,8 @@ !> @brief Checks pre-process input file parameters for compatibility and correctness module m_checker use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers - use m_helper implicit none diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index 341225dfe9..f0a06843ec 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -5,11 +5,8 @@ !> @brief Writes grid and initial condition data to serial or parallel output files module m_data_output use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_helper - use m_mpi_proxy !< Message passing interface (MPI) module proxy #ifdef MFC_MPI @@ -17,19 +14,12 @@ module m_data_output #endif use m_compile_specific - use m_variables_conversion - use m_helper - use m_delay_file_access - use m_boundary_common - use m_boundary_conditions - use m_thermochem, only: species_names - use m_helper implicit none @@ -74,21 +64,21 @@ contains logical :: file_exist !< checks if file exists character(LEN=15) :: FMT character(LEN=3) :: status - character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< Used to store + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< Used to store !! the number, in character form, of the currently !! manipulated conservative variable data file character(LEN=len_trim(t_step_dir) + name_len) :: file_loc !< !! Generic string used to store the address of a particular file - integer :: i, j, k, l, r, c !< Generic loop iterator + integer :: i, j, k, l, r, c !< Generic loop iterator integer :: t_step - real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration + real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration real(wp) :: nbub !< Temporary bubble number density real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params real(wp) :: rho !< Temporary density - real(wp) :: pres, T !< Temporary pressure - real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions + real(wp) :: pres, T !< Temporary pressure + real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions real(wp) :: pres_mag pres_mag = 0._wp @@ -209,7 +199,7 @@ contains if ((i >= chemxb) .and. (i <= chemxe)) then write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0)/rho else if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) .or. ((i >= adv_idx%beg) .and. (i <= adv_idx%end) & - & ) .or. ((i >= chemxb) .and. (i <= chemxe))) then + & ) .or. ((i >= chemxb) .and. (i <= chemxe))) then write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0) else if (i == mom_idx%beg) then ! u write (2, FMT) x_cb(j), q_cons_vf(mom_idx%beg)%sf(j, 0, 0)/rho @@ -218,12 +208,12 @@ contains else if (i == E_idx) then ! p if (mhd) then pres_mag = 0.5_wp*(Bx0**2 + q_cons_vf(B_idx%beg)%sf(j, 0, 0)**2 + q_cons_vf(B_idx%beg + 1)%sf(j, & - & 0, 0)**2) + & 0, 0)**2) end if call s_compute_pressure(q_cons_vf(E_idx)%sf(j, 0, 0), q_cons_vf(alf_idx)%sf(j, 0, 0), & - & 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, 0, 0)**2._wp)/rho, pi_inf, gamma, rho, & - & qv, rhoYks, pres, T, pres_mag=pres_mag) + & 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, 0, 0)**2._wp)/rho, pi_inf, gamma, rho, qv, rhoYks, pres, & + & T, pres_mag=pres_mag) write (2, FMT) x_cb(j), pres else if (mhd) then if (i == mom_idx%beg + 1) then ! v @@ -274,7 +264,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -286,7 +276,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -322,7 +312,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -336,7 +326,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -377,7 +367,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -393,7 +383,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -409,6 +399,7 @@ contains end if end if end subroutine s_write_serial_data_files + !> Writes grid and initial condition data files in parallel to the "0" time-step directory in the local processor rank folder !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables @@ -619,6 +610,7 @@ contains end if end if end subroutine s_write_parallel_data_files + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_data_output_module ! Generic string used to store the address of a particular file @@ -679,7 +671,7 @@ contains do i = contxb, contxe write (temp, '(I0)') i - contxb + 1 write (1, '(I3,A20,A20)') i, "\alpha_{" // trim(temp) // "} \rho_{" // trim(temp) // "}", & - & "\alpha_{" // trim(temp) // "} \rho" + & "\alpha_{" // trim(temp) // "} \rho" end do do i = momxb, momxe write (1, '(I3,A20,A20)') i, "\rho u_" // coord(i - momxb + 1), "u_" // coord(i - momxb + 1) @@ -694,7 +686,7 @@ contains if (chemistry) then do i = 1, num_species write (1, '(I3,A20,A20)') chemxb + i - 1, "Y_{" // trim(species_names(i)) // "} \rho", & - & "Y_{" // trim(species_names(i)) // "}" + & "Y_{" // trim(species_names(i)) // "}" end do end if @@ -721,6 +713,7 @@ contains end do end if end subroutine s_initialize_data_output_module + !> Resets s_write_data_files pointer impure subroutine s_finalize_data_output_module integer :: i diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 4877655685..fbc07adda2 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -11,19 +11,17 @@ module m_global_parameters #endif use m_derived_types ! Definitions of the derived types - use m_helper_basic ! Functions to compare floating point numbers - use m_thermochem, only: num_species implicit none ! Logistics - integer :: num_procs !< Number of processors - character(LEN=path_len) :: case_dir !< Case folder location - logical :: old_grid !< Use existing grid data - logical :: old_ic, non_axis_sym !< Use existing IC data - integer :: t_step_old, t_step_start !< Existing IC/grid folder + integer :: num_procs !< Number of processors + character(LEN=path_len) :: case_dir !< Case folder location + logical :: old_grid !< Use existing grid data + logical :: old_ic, non_axis_sym !< Use existing IC data + integer :: t_step_old, t_step_start !< Existing IC/grid folder logical :: cfl_adap_dt, cfl_const_dt, cfl_dt integer :: n_start, n_start_old @@ -38,13 +36,13 @@ module m_global_parameters !> @name Max and min number of cells in a direction of each combination of x-,y-, and z- type(cell_num_bounds) :: cells_bounds - integer(kind=8) :: nGlobal !< Global number of cells in the domain + integer(kind=8) :: nGlobal !< Global number of cells in the domain integer :: m_glb, n_glb, p_glb !< Global number of cells in each direction - integer :: num_dims !< Number of spatial dimensions - integer :: num_vels !< Number of velocity components (different from num_dims for mhd) + integer :: num_dims !< Number of spatial dimensions + integer :: num_vels !< Number of velocity components (different from num_dims for mhd) logical :: cyl_coord - integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) - real(wp), allocatable, dimension(:) :: x_cc, y_cc, z_cc !< + integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) + real(wp), allocatable, dimension(:) :: x_cc, y_cc, z_cc !< !! Locations of cell-centers (cc) in x-, y- and z-directions, respectively real(wp), allocatable, dimension(:) :: x_cb, y_cb, z_cb !< @@ -69,51 +67,51 @@ module m_global_parameters real(wp) :: x_b, y_b, z_b ! Simulation Algorithm Parameters - integer :: model_eqns !< Multicomponent flow model - logical :: relax !< activate phase change - integer :: relax_model !< Relax Model - real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model - real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model - integer :: num_fluids !< Number of different fluids present in the flow - logical :: mpp_lim !< Alpha limiter - integer :: sys_size !< Number of unknowns in the system of equations - integer :: recon_type !< Reconstruction Type - integer :: weno_polyn !< Degree of the WENO polynomials (polyn) - integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn) - integer :: weno_order !< Order of accuracy for the WENO reconstruction - integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction - logical :: hypoelasticity !< activate hypoelasticity - logical :: hyperelasticity !< activate hyperelasticity - logical :: elasticity !< elasticity modeling, true for hyper or hypo - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity for RMHD - integer :: b_size !< Number of components in the b tensor - integer :: tensor_size !< Number of components in the nonsymmetric tensor - logical :: pre_stress !< activate pre_stressed domain - logical :: cont_damage !< continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD - logical :: igr !< Use information geometric regularization - integer :: igr_order !< IGR reconstruction order + integer :: model_eqns !< Multicomponent flow model + logical :: relax !< activate phase change + integer :: relax_model !< Relax Model + real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model + real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model + integer :: num_fluids !< Number of different fluids present in the flow + logical :: mpp_lim !< Alpha limiter + integer :: sys_size !< Number of unknowns in the system of equations + integer :: recon_type !< Reconstruction Type + integer :: weno_polyn !< Degree of the WENO polynomials (polyn) + integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn) + integer :: weno_order !< Order of accuracy for the WENO reconstruction + integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction + logical :: hypoelasticity !< activate hypoelasticity + logical :: hyperelasticity !< activate hyperelasticity + logical :: elasticity !< elasticity modeling, true for hyper or hypo + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity for RMHD + integer :: b_size !< Number of components in the b tensor + integer :: tensor_size !< Number of components in the nonsymmetric tensor + logical :: pre_stress !< activate pre_stressed domain + logical :: cont_damage !< continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD + logical :: igr !< Use information geometric regularization + integer :: igr_order !< IGR reconstruction order logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling ! Annotations of the structure, i.e. the organization, of the state vectors - type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. - type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of total energy equation - integer :: alf_idx !< Index of void fraction - integer :: n_idx !< Index of number density - type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. - type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. - type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. - type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. - type(int_bounds_info) :: stress_idx !< Indexes of elastic shear stress eqns. - type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: c_idx !< Index of the color function - type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. + type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. + integer :: E_idx !< Index of total energy equation + integer :: alf_idx !< Index of void fraction + integer :: n_idx !< Index of number density + type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. + type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. + type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. + type(int_bounds_info) :: stress_idx !< Indexes of elastic shear stress eqns. + type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. + integer :: c_idx !< Index of the color function + type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). ! Stands for "InDices With BUFFer". @@ -135,13 +133,13 @@ module m_global_parameters !! Indices of shear stress components to reflect for boundary conditions. !! Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, [indices]) - logical :: parallel_io !< Format of the data files - logical :: file_per_process !< type of data output - integer :: precision !< Precision of output files - logical :: down_sample !< Down-sample the output data + logical :: parallel_io !< Format of the data files + logical :: file_per_process !< type of data output + integer :: precision !< Precision of output files + logical :: down_sample !< Down-sample the output data logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile - real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile - logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow + real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile + logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag real(wp) :: mixlayer_perturb_k0 !< Peak wavenumber of prescribed energy spectra with mixlayer_perturb flag !! Default value (k0 = 0.4446) is most unstable mode obtained from linear stability analysis @@ -154,14 +152,14 @@ module m_global_parameters ! Perturb density of surrounding air so as to break symmetry of grid logical :: perturb_flow - integer :: perturb_flow_fluid !< Fluid to be perturbed with perturb_flow flag + integer :: perturb_flow_fluid !< Fluid to be perturbed with perturb_flow flag real(wp) :: perturb_flow_mag !< Magnitude of perturbation with perturb_flow flag logical :: perturb_sph - integer :: perturb_sph_fluid !< Fluid to be perturbed with perturb_sph flag + integer :: perturb_sph_fluid !< Fluid to be perturbed with perturb_sph flag real(wp), dimension(num_fluids_max) :: fluid_rho logical :: elliptic_smoothing integer :: elliptic_smoothing_iters - integer, allocatable, dimension(:) :: proc_coords !< + integer, allocatable, dimension(:) :: proc_coords !< !! Processor coordinates in MPI_CART_COMM integer, allocatable, dimension(:) :: start_idx !< @@ -176,15 +174,15 @@ module m_global_parameters #endif ! Initial Condition Parameters - integer :: num_patches !< Number of patches composing initial condition - type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp !< + integer :: num_patches !< Number of patches composing initial condition + type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp !< !! Database of the initial condition patch parameters (icpp) for each of the !! patches employed in the configuration of the initial condition. Note that !! the maximum allowable number of patches, num_patches_max, may be changed !! in the module m_derived_types.f90. - integer :: num_bc_patches !< Number of boundary condition patches - logical :: bc_io !< whether or not to save BC data + integer :: num_bc_patches !< Number of boundary condition patches + logical :: bc_io !< whether or not to save BC data type(bc_patch_parameters), dimension(num_bc_patches_max) :: patch_bc !! Database of the boundary condition patch parameters for each of the patches !! employed in the configuration of the boundary conditions @@ -205,16 +203,16 @@ module m_global_parameters real(wp) :: Ca, Web, Re_inv, Eu real(wp), dimension(:), allocatable :: weight, R0 logical :: bubbles_euler - logical :: qbmm !< Quadrature moment method - integer :: nmom !< Number of carried moments + logical :: qbmm !< Quadrature moment method + integer :: nmom !< Number of carried moments real(wp) :: sigR, sigV, rhoRV !< standard deviations in R/V logical :: adv_n !< Solve the number density equation and compute alpha from number density !> @} !> @name Immersed Boundaries !> @{ - logical :: ib !< Turn immersed boundaries on - integer :: num_ibs !< Number of immersed boundaries + logical :: ib !< Turn immersed boundaries on + integer :: num_ibs !< Number of immersed boundaries integer :: Np type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l @@ -261,7 +259,7 @@ module m_global_parameters integer, allocatable, dimension(:,:,:) :: logic_grid type(pres_field) :: pb type(pres_field) :: mv - real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) + real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) integer :: buff_size !< !! The number of cells that are necessary to be able to store enough boundary !! conditions data to march the solution in the physical computational domain @@ -593,6 +591,7 @@ contains bub_pp%R_v = dflt_real; R_v = dflt_real bub_pp%R_g = dflt_real; R_g = dflt_real end subroutine s_assign_default_values_to_user_inputs + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_global_parameters_module integer :: i, j, fac @@ -880,7 +879,7 @@ contains chemxe = species_idx%end call s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & - & bubbles_lagrange, m, n, p, num_dims, igr, ib) + & bubbles_lagrange, m, n, p, num_dims, igr, ib) #ifdef MFC_MPI @@ -928,6 +927,7 @@ contains allocate (logic_grid(0:m, 0:n, 0:p)) end if end subroutine s_initialize_global_parameters_module + !> @brief Configures MPI parallel I/O settings and allocates processor coordinate arrays. impure subroutine s_initialize_parallel_io #ifdef MFC_MPI @@ -962,6 +962,7 @@ contains allocate (start_idx(1:num_dims)) #endif end subroutine s_initialize_parallel_io + !> @brief Deallocates all global grid, index, and equation-of-state parameter arrays. impure subroutine s_finalize_global_parameters_module integer :: i diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index b0ae678d22..547226ba6e 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -5,11 +5,8 @@ !> @brief Generates uniform or stretched rectilinear grids with hyperbolic-tangent spacing module m_grid use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters for the code - use m_mpi_proxy ! Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers #ifdef MFC_MPI @@ -36,8 +33,8 @@ end subroutine s_generate_abstract_grid !! cell-boundaries. impure subroutine s_generate_serial_grid ! Generic loop iterator - integer :: i, j !< generic loop operators - real(wp) :: length !< domain lengths + integer :: i, j !< generic loop operators + real(wp) :: length !< domain lengths ! Grid Generation in the x-direction dx = (x_domain%end - x_domain%beg)/real(m + 1, wp) @@ -58,7 +55,7 @@ impure subroutine s_generate_serial_grid do j = 1, loops_x do i = -1, m x_cb(i) = x_cb(i)/a_x*(a_x + log(cosh(a_x*(x_cb(i) - x_a))) + log(cosh(a_x*(x_cb(i) - x_b))) & - & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) + & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) end do end do x_cb = x_cb*length @@ -105,7 +102,7 @@ impure subroutine s_generate_serial_grid do j = 1, loops_y do i = -1, n y_cb(i) = y_cb(i)/a_y*(a_y + log(cosh(a_y*(y_cb(i) - y_a))) + log(cosh(a_y*(y_cb(i) - y_b))) & - & - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) + & - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) end do end do @@ -138,7 +135,7 @@ impure subroutine s_generate_serial_grid do j = 1, loops_z do i = -1, p z_cb(i) = z_cb(i)/a_z*(a_z + log(cosh(a_z*(z_cb(i) - z_a))) + log(cosh(a_z*(z_cb(i) - z_b))) & - & - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) + & - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) end do end do @@ -150,6 +147,7 @@ impure subroutine s_generate_serial_grid if (num_procs > 1) call s_mpi_reduce_min(dz) end if end subroutine s_generate_serial_grid + !> The following subroutine generates either a uniform or non-uniform rectilinear grid in parallel, defined by the parameters !! inputted by the user. The grid information is stored in the grid variables containing coordinates of the cell- centers and !! cell-boundaries. @@ -190,7 +188,7 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_x do i = -1, m_glb x_cb_glb(i) = x_cb_glb(i)/a_x*(a_x + log(cosh(a_x*(x_cb_glb(i) - x_a))) + log(cosh(a_x*(x_cb_glb(i) - x_b))) & - & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) + & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) end do end do @@ -223,7 +221,7 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_y do i = -1, n_glb y_cb_glb(i) = y_cb_glb(i)/a_y*(a_y + log(cosh(a_y*(y_cb_glb(i) - y_a))) + log(cosh(a_y*(y_cb_glb(i) - y_b) & - & )) - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) + & )) - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) end do end do @@ -247,7 +245,7 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_z do i = -1, p_glb z_cb_glb(i) = z_cb_glb(i)/a_z*(a_z + log(cosh(a_z*(z_cb_glb(i) - z_a))) + log(cosh(a_z*(z_cb_glb(i) & - & - z_b))) - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) + & - z_b))) - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) end do end do @@ -282,6 +280,7 @@ impure subroutine s_generate_parallel_grid deallocate (x_cb_glb, y_cb_glb, z_cb_glb) #endif end subroutine s_generate_parallel_grid + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_grid_module if (parallel_io .neqv. .true.) then @@ -290,6 +289,7 @@ impure subroutine s_initialize_grid_module s_generate_grid => s_generate_parallel_grid end if end subroutine s_initialize_grid_module + !> Deallocation procedures for the module impure subroutine s_finalize_grid_module s_generate_grid => null() diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 996fcc5689..17d8475a54 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -12,23 +12,14 @@ !> @brief Constructs initial condition patch geometries (lines, circles, rectangles, spheres, etc.) on the grid module m_icpp_patches use m_model ! Subroutine(s) related to STL files - use m_derived_types ! Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_constants, only: max_2d_fourier_modes, max_sph_harm_degree, small_radius - use m_helper_basic !< Functions to compare floating point numbers - use m_helper - use m_mpi_common - use m_assign_variables - use m_mpi_common - use m_variables_conversion implicit none @@ -135,7 +126,7 @@ contains ! Unimplemented patch (formerly isentropic vortex) else if (patch_icpp(i)%geometry == 6) then call s_mpi_abort('This used to be the isentropic vortex patch, ' & - & // 'which no longer exists. See Examples. Exiting.') + & // 'which no longer exists. See Examples. Exiting.') ! 2D modal (Fourier) patch else if (patch_icpp(i)%geometry == 13) then call s_icpp_2d_modal(i, patch_id_fp, q_prim_vf) @@ -173,6 +164,7 @@ contains end do end if end subroutine s_apply_icpp_patches + !> The line segment patch is a 1D geometry that may be used, for example, in creating a Riemann problem. The geometry of the !! patch is well-defined when its centroid and length in the x-coordinate direction are provided. Note that the line segment !! patch DOES NOT allow for the smearing of its boundaries. @@ -239,6 +231,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_line_segment + !> The spiral patch is a 2D geometry that may be used, The geometry of the patch is well-defined when its centroid and radius !! are provided. Note that the circular patch DOES allow for the smoothing of its boundary. !! @param patch_id patch identifier @@ -302,6 +295,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_spiral + !> The circular patch is a 2D geometry that may be used, for example, in creating a bubble or a droplet. The geometry of the !! patch is well-defined when its centroid and radius are provided. Note that the circular patch DOES allow for the smoothing of !! its boundary. @@ -344,7 +338,7 @@ contains do i = 0, m if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, & - & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp + & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp end if if (((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2 <= radius**2 .and. patch_icpp(patch_id) & @@ -360,6 +354,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_circle + !> The varcircle patch is a 2D geometry that may be used . It generatres an annulus !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids @@ -415,12 +410,13 @@ contains if (1._wp - eta < sgm_eps) patch_id_fp(i, j, 0) = patch_id q_prim_vf(alf_idx)%sf(i, j, & - & 0) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) + & 0) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) end if end do end do @:HardcodedDellacation() end subroutine s_icpp_varcircle + !> @brief Initializes a 3D variable-thickness circular annulus patch extruded along the z-axis. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids @@ -481,13 +477,14 @@ contains if (1._wp - eta < sgm_eps) patch_id_fp(i, j, k) = patch_id q_prim_vf(alf_idx)%sf(i, j, & - & k) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) + & k) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) end if end do end do end do @:HardcodedDellacation() end subroutine s_icpp_3dvarcircle + !> The elliptical patch is a 2D geometry. The geometry of the patch is well-defined when its centroid and radii are provided. !! Note that the elliptical patch DOES allow for the smoothing of its boundary !! @param patch_id is the patch identifier @@ -529,8 +526,7 @@ contains do i = 0, m if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, & - & dy)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((y_cc(j) - y_centroid)/b)**2) - 1._wp))*(-0.5_wp) & - & + 0.5_wp + & dy)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((y_cc(j) - y_centroid)/b)**2) - 1._wp))*(-0.5_wp) + 0.5_wp end if if ((((x_cc(i) - x_centroid)/a)**2 + ((y_cc(j) - y_centroid)/b)**2 <= 1._wp .and. patch_icpp(patch_id) & @@ -549,6 +545,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_ellipse + !> The ellipsoidal patch is a 3D geometry. The geometry of the patch is well-defined when its centroid and radii are provided. !! Note that the ellipsoidal patch DOES allow for the smoothing of its boundary !! @param patch_id is the patch identifier @@ -603,8 +600,8 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, dy, & - & dz)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((cart_y - y_centroid)/b)**2 + ((cart_z & - & - z_centroid)/c)**2) - 1._wp))*(-0.5_wp) + 0.5_wp + & dz)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((cart_y - y_centroid)/b)**2 + ((cart_z - z_centroid)/c) & + & **2) - 1._wp))*(-0.5_wp) + 0.5_wp end if if ((((x_cc(i) - x_centroid)/a)**2 + ((cart_y - y_centroid)/b)**2 + ((cart_z - z_centroid)/c) & @@ -625,6 +622,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_ellipsoid + !> The rectangular patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock !! region, in alignment with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x- and y- coordinate directions are provided. Please note that the rectangular patch DOES NOT @@ -640,7 +638,7 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< generic loop iterators + integer :: i, j, k !< generic loop iterators real(wp) :: pi_inf, gamma, lit_gamma !< Equation of state parameters @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -688,8 +686,7 @@ contains if ((q_prim_vf(1)%sf(i, j, 0) < 1.e-10) .and. (model_eqns == 4)) then ! zero density, reassign according to Tait EOS q_prim_vf(1)%sf(i, j, 0) = (((q_prim_vf(E_idx)%sf(i, j, & - & 0) + pi_inf)/(pref + pi_inf))**(1._wp/lit_gamma))*rhoref*(1._wp - q_prim_vf(alf_idx) & - & %sf(i, j, 0)) + & 0) + pi_inf)/(pref + pi_inf))**(1._wp/lit_gamma))*rhoref*(1._wp - q_prim_vf(alf_idx) %sf(i, j, 0)) end if ! Updating the patch identities bookkeeping variable @@ -700,6 +697,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_rectangle + !> The swept line patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock !! region, at an angle with respect to the axes of the Cartesian coordinate system. The geometry of the patch is well-defined !! when its centroid and normal vector, aimed in the sweep direction, are provided. Note that the sweep line patch DOES allow @@ -762,6 +760,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_sweep_line + !> The Taylor Green vortex is 2D decaying vortex that may be used, for example, to verify the effects of viscous attenuation. !! Geometry of the patch is well-defined when its centroid are provided. !! @param patch_id is the patch identifier @@ -775,9 +774,9 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< generic loop iterators + integer :: i, j, k !< generic loop iterators real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters - real(wp) :: L0, U0 !< Taylor Green Vortex parameters + real(wp) :: L0, U0 !< Taylor Green Vortex parameters @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -830,13 +829,14 @@ contains q_prim_vf(mom_idx%beg)%sf(i, j, 0) = U0*sin(x_cc(i)/L0)*cos(y_cc(j)/L0) q_prim_vf(mom_idx%end)%sf(i, j, 0) = -U0*cos(x_cc(i)/L0)*sin(y_cc(j)/L0) q_prim_vf(E_idx)%sf(i, j, & - & 0) = patch_icpp(patch_id)%pres + (cos(2*x_cc(i))/L0 + cos(2*y_cc(j))/L0)*(q_prim_vf(1)%sf(i, j, & - & 0)*U0*U0)/16 + & 0) = patch_icpp(patch_id)%pres + (cos(2*x_cc(i))/L0 + cos(2*y_cc(j))/L0)*(q_prim_vf(1)%sf(i, j, & + & 0)*U0*U0)/16 end if end do end do @:HardcodedDellacation() end subroutine s_icpp_2D_TaylorGreen_Vortex + !> @brief Initializes a 1D bubble-pulse patch with analytical primitive variable profiles. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids @@ -897,6 +897,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_1D_bubble_pulse + !> 2D modal (Fourier) patch. theta = atan2(y - y_centroid, x - x_centroid). Additive (modal_use_exp_form false): R = radius + !! sum_n [fourier_cos*cos(n*theta)+fourier_sin*sin(n*theta)]; coefficients are absolute (same units as radius). R is clipped to !! max(R,0). If modal_clip_r_to_min, R = max(R, modal_r_min). Exponential (modal_use_exp_form true): R = radius*exp(sum); @@ -929,7 +930,7 @@ contains sum_series = 0._wp do nn = 1, max_2d_fourier_modes sum_series = sum_series + patch_icpp(patch_id)%fourier_cos(nn)*cos(real(nn, & - & wp)*theta) + patch_icpp(patch_id)%fourier_sin(nn)*sin(real(nn, wp)*theta) + & wp)*theta) + patch_icpp(patch_id)%fourier_sin(nn)*sin(real(nn, wp)*theta) end do if (patch_icpp(patch_id)%modal_use_exp_form) then R_boundary = patch_icpp(patch_id)%radius*exp(sum_series) @@ -950,6 +951,7 @@ contains end do end do end subroutine s_icpp_2d_modal + !> 3D spherical harmonic patch. Surface r = radius + sum_lm sph_har_coeff(l,m)*Y_lm(theta,phi). theta = acos(z/r), phi = !! atan2(y,x) relative to centroid. subroutine s_icpp_3d_spherical_harmonic(patch_id, patch_id_fp, q_prim_vf) @@ -1009,6 +1011,7 @@ contains end do end do end subroutine s_icpp_3d_spherical_harmonic + !> The spherical patch is a 3D geometry that may be used, for example, in creating a bubble or a droplet. The patch geometry is !! well-defined when its centroid and radius are provided. Please note that the spherical patch DOES allow for the smoothing of !! its boundary. @@ -1063,8 +1066,8 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, dy, & - & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) & - & - radius))*(-0.5_wp) + 0.5_wp + & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) - radius) & + & )*(-0.5_wp) + 0.5_wp end if if ((((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2 + (cart_z - z_centroid)**2 <= radius**2) & @@ -1082,6 +1085,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_sphere + !> The cuboidal patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post-shock region, !! which is aligned with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x-, y- and z-coordinate directions are provided. Please notice that the cuboidal patch DOES NOT @@ -1157,6 +1161,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_cuboid + !> The cylindrical patch is a 3D geometry that may be used, for example, in setting up a cylindrical solid boundary confinement, !! like a blood vessel. The geometry of this patch is well-defined when the centroid, the radius and the length along the !! cylinder's axis, parallel to the x-, y- or z-coordinate direction, are provided. Please note that the cylindrical patch DOES @@ -1220,16 +1225,13 @@ contains if (patch_icpp(patch_id)%smoothen) then if (.not. f_is_default(length_x)) then eta = tanh(smooth_coeff/min(dy, & - & dz)*(sqrt((cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) & - & + 0.5_wp + & dz)*(sqrt((cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp else if (.not. f_is_default(length_y)) then eta = tanh(smooth_coeff/min(dx, & - & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) & - & + 0.5_wp + & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp else eta = tanh(smooth_coeff/min(dx, & - & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2) - radius))*(-0.5_wp) & - & + 0.5_wp + & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp end if end if @@ -1256,6 +1258,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_cylinder + !> The swept plane patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock !! region, at an angle with respect to the axes of the Cartesian coordinate system. The geometry of the patch is well-defined !! when its centroid and normal vector, aimed in the sweep direction, are provided. Note that the sweep plane patch DOES allow @@ -1310,7 +1313,7 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = 5.e-1_wp + 5.e-1_wp*tanh(smooth_coeff/min(dx, dy, & - & dz)*(a*x_cc(i) + b*cart_y + c*cart_z + d)/sqrt(a**2 + b**2 + c**2)) + & dz)*(a*x_cc(i) + b*cart_y + c*cart_z + d)/sqrt(a**2 + b**2 + c**2)) end if if ((a*x_cc(i) + b*cart_y + c*cart_z + d >= 0._wp .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, & @@ -1330,6 +1333,7 @@ contains end do @:HardcodedDellacation() end subroutine s_icpp_sweep_plane + !> The STL patch is a 2/3D geometry that is imported from an STL file. !! @param patch_id is the patch identifier !! @param patch_id_fp Array to track patch ids @@ -1459,6 +1463,7 @@ contains call s_model_free(model) end subroutine s_icpp_model + !> @brief Converts cylindrical (r, theta) coordinates to Cartesian (y, z) module variables. subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) $:GPU_ROUTINE(parallelism='[seq]') @@ -1468,6 +1473,7 @@ contains cart_y = cyl_y*sin(cyl_z) cart_z = cyl_y*cos(cyl_z) end subroutine s_convert_cylindrical_to_cartesian_coord + !> @brief Returns a 3D Cartesian coordinate vector from a cylindrical (x, r, theta) input vector. function f_convert_cyl_to_cart(cyl) result(cart) $:GPU_ROUTINE(parallelism='[seq]') @@ -1477,6 +1483,7 @@ contains cart = (/cyl(1), cyl(2)*sin(cyl(3)), cyl(2)*cos(cyl(3))/) end function f_convert_cyl_to_cart + !> @brief Computes the spherical azimuthal angle from cylindrical (x, r) coordinates. subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) $:GPU_ROUTINE(parallelism='[seq]') @@ -1485,6 +1492,7 @@ contains sph_phi = atan(cyl_y/cyl_x) end subroutine s_convert_cylindrical_to_spherical_coord + !> Archimedes spiral function !! @param myth Angle !! @param offset Thickness diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 6ebcfaa4bb..093d42fdbd 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -5,24 +5,16 @@ !> @brief Assembles initial conditions by layering prioritized patches via constructive solid geometry module m_initial_condition use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper - use m_variables_conversion ! Subroutines to change the state variables from ! one form to another use m_icpp_patches - use m_assign_variables - use m_perturbation ! Subroutines to perturb initial flow fields - use m_chemistry - use m_boundary_conditions implicit none @@ -33,8 +25,8 @@ module m_initial_condition ! a cell in the computational domain. type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< primitive variables type(scalar_field), allocatable, dimension(:) :: q_cons_vf !< conservative variables - type(scalar_field) :: q_T_sf !< Temperature field - type(integer_field), dimension(:,:), allocatable :: bc_type !< bc_type fields + type(scalar_field) :: q_T_sf !< Temperature field + type(integer_field), dimension(:,:), allocatable :: bc_type !< bc_type fields !> @cond #ifdef MFC_MIXED_PRECISION @@ -139,6 +131,7 @@ contains ! when it is being applied in the domain. patch_id_fp = 0 end subroutine s_initialize_initial_condition_module + !> This subroutine peruses the patches and depending on the type of geometry associated with a particular patch, it calls the !! related subroutine to setup the said geometry on the grid using the primitive variables included with the patch parameters. !! The subroutine is complete once the primitive variables are converted to conservative ones. @@ -172,6 +165,7 @@ contains call s_initialize_pb(q_cons_vf, mv%sf, pb%sf) end if end subroutine s_generate_initial_condition + !> Deallocation procedures for the module impure subroutine s_finalize_initial_condition_module integer :: i !< Generic loop iterator diff --git a/src/pre_process/m_mpi_proxy.fpp b/src/pre_process/m_mpi_proxy.fpp index 5c4fac4839..22f8156ed3 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -9,11 +9,8 @@ module m_mpi_proxy #endif use m_helper - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_common implicit none diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index 47675b5173..ff8b59a487 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -5,17 +5,11 @@ !> @brief Perturbs initial mean flow fields with random noise, mixing-layer instabilities, or simplex noise module m_perturbation use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_boundary_common ! Boundary conditions module - use m_helper - use m_simplex_noise - use ieee_arithmetic implicit none @@ -29,6 +23,7 @@ contains allocate (q_prim_temp(0:m, 0:n, 0:p, 1:sys_size)) end if end subroutine s_initialize_perturbation_module + !> @brief Randomly perturbs partial density fields at the interface of a spherical volume fraction region. impure subroutine s_perturb_sphere(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -56,6 +51,7 @@ contains end do end do end subroutine s_perturb_sphere + !> @brief Adds random noise to the velocity and void fraction of the surrounding flow field. impure subroutine s_perturb_surrounding_flow(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -80,6 +76,7 @@ contains end do end do end subroutine s_perturb_surrounding_flow + !> @brief Iteratively smooths all primitive variable fields using a discrete elliptic (Laplacian) filter. impure subroutine s_elliptic_smoothing(q_prim_vf, bc_type) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -95,7 +92,7 @@ contains do j = 0, m do i = 1, sys_size q_prim_temp(j, 0, 0, i) = (1._wp/4._wp)*(q_prim_vf(i)%sf(j + 1, 0, 0) + q_prim_vf(i)%sf(j - 1, 0, & - & 0) + 2._wp*q_prim_vf(i)%sf(j, 0, 0)) + & 0) + 2._wp*q_prim_vf(i)%sf(j, 0, 0)) end do end do else if (p == 0) then @@ -103,8 +100,7 @@ contains do j = 0, m do i = 1, sys_size q_prim_temp(j, k, 0, i) = (1._wp/8._wp)*(q_prim_vf(i)%sf(j + 1, k, 0) + q_prim_vf(i)%sf(j - 1, k, & - & 0) + q_prim_vf(i)%sf(j, k + 1, 0) + q_prim_vf(i)%sf(j, k - 1, & - & 0) + 4._wp*q_prim_vf(i)%sf(j, k, 0)) + & 0) + q_prim_vf(i)%sf(j, k + 1, 0) + q_prim_vf(i)%sf(j, k - 1, 0) + 4._wp*q_prim_vf(i)%sf(j, k, 0)) end do end do end do @@ -114,9 +110,8 @@ contains do j = 0, m do i = 1, sys_size q_prim_temp(j, k, l, i) = (1._wp/12._wp)*(q_prim_vf(i)%sf(j + 1, k, l) + q_prim_vf(i)%sf(j - 1, & - & k, l) + q_prim_vf(i)%sf(j, k + 1, l) + q_prim_vf(i)%sf(j, k - 1, & - & l) + q_prim_vf(i)%sf(j, k, l + 1) + q_prim_vf(i)%sf(j, k, & - & l - 1) + 6._wp*q_prim_vf(i)%sf(j, k, l)) + & k, l) + q_prim_vf(i)%sf(j, k + 1, l) + q_prim_vf(i)%sf(j, k - 1, l) + q_prim_vf(i)%sf(j, k, & + & l + 1) + q_prim_vf(i)%sf(j, k, l - 1) + 6._wp*q_prim_vf(i)%sf(j, k, l)) end do end do end do @@ -135,6 +130,7 @@ contains end do end do end subroutine s_elliptic_smoothing + !> @brief Perturbs velocity and volume fraction fields using multi-octave simplex noise. subroutine s_perturb_simplex(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -209,7 +205,7 @@ contains mag = f_simplex3d(xl, yl, zl) end if q_prim_vf(contxb + i - 1)%sf(j, k, l) = q_prim_vf(contxb + i - 1)%sf(j, k, & - & l) + q_prim_vf(contxb + i - 1)%sf(j, k, l)*scale*mag + & l) + q_prim_vf(contxb + i - 1)%sf(j, k, l)*scale*mag end do end do end do @@ -218,6 +214,7 @@ contains deallocate (ofs) end subroutine s_perturb_simplex + !> This subroutine computes velocity perturbations for a temporal mixing layer with a hyperbolic tangent mean streamwise !! velocity profile, using an inverted version of the spectrum-based synthetic turbulence generation method proposed by Guo et !! al. (2023, JFM). @@ -297,6 +294,7 @@ contains end do end do end subroutine s_perturb_mixlayer + !> @brief Generates deterministic pseudo-random wave vector, polarization, and phase for a perturbation mode. subroutine s_generate_random_perturbation(khat, xi, phi, ik, yloc) integer, intent(in) :: ik @@ -320,6 +318,7 @@ contains call s_prng(phi, seed) end subroutine s_generate_random_perturbation + !> @brief Generates a unit vector uniformly distributed on the sphere from two random parameters. function f_unit_vector(theta, eta) result(vec) real(wp), intent(in) :: theta, eta @@ -332,6 +331,7 @@ contains vec(2) = sin(zeta)*sin(xi) vec(3) = cos(zeta) end function f_unit_vector + !> This function generates a pseudo-random number between 0 and 1 based on linear congruential generator. subroutine s_prng(var, seed) integer, intent(inout) :: seed @@ -341,6 +341,7 @@ contains seed = mod(modmul(seed), modulus) var = seed/real(modulus, wp) end subroutine s_prng + !> @brief Computes a modular multiplication step for the linear congruential pseudo-random number generator. function modmul(a) result(val) integer, intent(in) :: a @@ -351,6 +352,7 @@ contains y = nint((x - floor(x))*decimal_trim)/decimal_trim val = nint(y*modulus) end function modmul + !> @brief Deallocates the temporary primitive variable array used by elliptic smoothing. impure subroutine s_finalize_perturbation_module() if (elliptic_smoothing) then diff --git a/src/pre_process/m_simplex_noise.fpp b/src/pre_process/m_simplex_noise.fpp index 82f2c87a3a..5b8bc72e60 100644 --- a/src/pre_process/m_simplex_noise.fpp +++ b/src/pre_process/m_simplex_noise.fpp @@ -5,7 +5,6 @@ !> @brief 2D and 3D simplex noise generation for procedural initial condition perturbations module m_simplex_noise use m_constants - use m_precision_select implicit none @@ -13,37 +12,33 @@ module m_simplex_noise private; public :: f_simplex3d, f_simplex2d integer, parameter :: p_vec(0:511) = [151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, 53, 194, 233, 7, 225, 140, 36, 103, & - & 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, & - & 252, 219, 203, 117, 35, 11, 32, 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, 171, 168, & - & 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, 231, 83, 111, 229, 122, 60, 211, & - & 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, 63, 161, 1, 216, 80, & - & 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, 159, 86, 164, 100, 109, & - & 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, 147, 118, 126, 255, 82, 85, 212, & - & 207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, 183, 170, 213, 119, 248, 152, 2, 44, & - & 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, 129, 22, 39, 253, 19, 98, 108, 110, 79, 113, & - & 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, 34, 242, 193, 238, 210, 144, 12, 191, & - & 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, & - & 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, & - & 243, 141, 128, 195, 78, 66, 215, 61, 156, 180, 151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, & - & 53, 194, 233, 7, 225, 140, 36, 103, 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, & - & 120, 234, 75, 0, 26, 197, 62, 94, 252, 219, 203, 117, 35, 11, 32, 57, 177, 33, 88, 237, 149, & - & 56, 87, 174, 20, 125, 136, 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, & - & 231, 83, 111, 229, 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, & - & 54, 65, 25, 63, 161, 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, & - & 116, 188, 159, 86, 164, 100, 109, 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, & - & 38, 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, & - & 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, 129, & - & 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, & - & 34, 242, 193, 238, 210, 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, & - & 192, 214, 31, 181, 199, 106, 157, 184, 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, & - & 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, 66, 215, 61, 156, 180] + & 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, 252, 219, 203, 117, 35, & + & 11, 32, 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, & + & 77, 146, 158, 231, 83, 111, 229, 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, & + & 63, 161, 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, 159, 86, 164, 100, 109, & + & 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, & + & 16, 58, 17, 182, 189, 28, 42, 223, 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, & + & 9, 129, 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, 34, 242, 193, & + & 238, 210, 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, & + & 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, & + & 66, 215, 61, 156, 180, 151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, 53, 194, 233, 7, 225, 140, 36, 103, 30, 69, & + & 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, 252, 219, 203, 117, 35, 11, 32, & + & 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, & + & 158, 231, 83, 111, 229, 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, 63, 161, & + & 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, 159, 86, 164, 100, 109, 198, 173, & + & 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, 16, 58, & + & 17, 182, 189, 28, 42, 223, 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, 129, & + & 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, 34, 242, 193, 238, 210, & + & 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, 84, 204, & + & 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, 66, 215, & + & 61, 156, 180] real(wp), parameter :: grad3(12, 3) = reshape([1._wp, 1._wp, 0._wp, -1._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, -1._wp, & - & -1._wp, 0._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, 1._wp, 1._wp, 0._wp, -1._wp, -1._wp, 0._wp, -1._wp, 0._wp, 1._wp, & - & 1._wp, 0._wp, -1._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, -1._wp, -1._wp], shape=[12, 3]) + & -1._wp, 0._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, 1._wp, 1._wp, 0._wp, -1._wp, -1._wp, 0._wp, -1._wp, 0._wp, 1._wp, & + & 1._wp, 0._wp, -1._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, -1._wp, -1._wp], shape=[12, 3]) real(wp), parameter :: grad2(10, 2) = reshape([1._wp, 1._wp, -1._wp, 1._wp, 1._wp, -1._wp, -1._wp, -1._wp, 1._wp, 0._wp, & - & -1._wp, 0._wp, 0._wp, 1._wp, 0._wp, -1._wp, 1._wp, 1._wp, -1._wp, 1._wp], shape=[10, 2]) + & -1._wp, 0._wp, 0._wp, 1._wp, 0._wp, -1._wp, 1._wp, 1._wp, -1._wp, 1._wp], shape=[10, 2]) contains !> @brief Evaluates 3D simplex noise at the given coordinates and returns a value in [-1, 1]. @@ -144,6 +139,7 @@ contains n = 32._wp*(n0 + n1 + n2 + n3) end function f_simplex3d + !> @brief Evaluates 2D simplex noise at the given coordinates and returns a value in [-1, 1]. function f_simplex2d(xin, yin) result(n) real(wp), intent(in) :: xin, yin @@ -208,6 +204,7 @@ contains n = 70._wp*(n0 + n1 + n2) end function f_simplex2d + !> @brief Computes the dot product of a 2D gradient vector with the given offset coordinates. function dot2(g, x, y) result(dot) integer, intent(in) :: g diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index aaa5aeda92..978aefd47e 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -7,33 +7,22 @@ !> @brief Reads and validates user inputs, loads existing grid/IC data, and initializes pre-process modules module m_start_up use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_mpi_common - use m_variables_conversion !< Subroutines to change the state variables from !! one form to another use m_grid !< Procedures to generate (non-)uniform grids - use m_initial_condition !< Procedures to generate initial condition - use m_data_output !< Procedures to write the grid data and the !! conservative variables to files use m_compile_specific !< Compile-specific procedures - use m_icpp_patches - use m_assign_variables - use m_phase_change !< Phase-change module - use m_helper_basic !< Functions to compare floating point numbers - use m_helper #ifdef MFC_MPI @@ -41,17 +30,11 @@ module m_start_up #endif use m_check_patches - use m_check_ib_patches - use m_helper - use m_checker_common - use m_checker - use m_boundary_common - use m_boundary_conditions implicit none @@ -149,6 +132,7 @@ contains call s_mpi_abort('File pre_process.inp is missing. Exiting.') end if end subroutine s_read_input_file + !> Checking that the user inputs make sense, i.e. that the individual choices are compatible with the code's options and that !! the combination of these choices results into a valid configuration for the pre-process impure subroutine s_check_input_file @@ -179,6 +163,7 @@ contains if (ib) call s_check_ib_patches() end subroutine s_check_input_file + !> The goal of this subroutine is to read in any preexisting grid data as well as based on the imported grid, complete the !! necessary global computational domain parameters. impure subroutine s_read_serial_grid_data_files @@ -300,6 +285,7 @@ contains call s_create_directory(trim(proc_rank_dir) // '/0') end if end subroutine s_read_serial_grid_data_files + !> Cell-boundary data are checked for consistency by looking at the (non-)uniform cell-width distributions for all the active !! coordinate directions and making sure that all of the cell-widths are positively valued impure subroutine s_check_grid_data_files @@ -325,6 +311,7 @@ contains end if end if end subroutine s_check_grid_data_files + !> The goal of this subroutine is to read in any preexisting initial condition data files so that they may be used by the !! pre-process as a starting point in the creation of an all new initial condition. !! @param q_cons_vf_in Conservative variables @@ -410,6 +397,7 @@ contains call s_delete_directory(trim(proc_rank_dir)) call s_create_directory(trim(proc_rank_dir) // '/0') end subroutine s_read_serial_ic_data_files + !> Cell-boundary data are checked for consistency by looking at the (non-)uniform cell-width distributions for all the active !! coordinate directions and making sure that all of the cell-widths are positively valued impure subroutine s_read_parallel_grid_data_files @@ -504,6 +492,7 @@ contains deallocate (x_cb_glb, y_cb_glb, z_cb_glb) #endif end subroutine s_read_parallel_grid_data_files + !> The goal of this subroutine is to read in any preexisting initial condition data files so that they may be used by the !! pre-process as a starting point in the creation of an all new initial condition. !! @param q_cons_vf_in Conservative variables @@ -582,6 +571,7 @@ contains call s_mpi_barrier() #endif end subroutine s_read_parallel_ic_data_files + !> @brief Initializes all pre-process modules, allocates data structures, and sets I/O procedure pointers. impure subroutine s_initialize_modules ! Computation of parameters, allocation procedures, and/or any other tasks @@ -617,6 +607,7 @@ contains s_write_data_files => s_write_parallel_data_files end if end subroutine s_initialize_modules + !> @brief Reads an existing grid from data files or generates a new grid from user inputs. impure subroutine s_read_grid() if (old_grid) then @@ -633,6 +624,7 @@ contains end if end if end subroutine s_read_grid + !> @brief Generates or reads the initial condition, applies relaxation if needed, and writes output data files. impure subroutine s_apply_initial_condition(start, finish) real(wp), intent(inout) :: start, finish @@ -673,8 +665,7 @@ contains if (relax) then if (proc_rank == 0) then - print *, 'initial condition might have been altered due to enforcement of & - & pTg - equilibrium (relax="T" activated)' + print *, 'initial condition might have been altered due to enforcement of pTg-equilibrium (relax = "T" activated)' end if call s_infinite_relaxation_k(q_cons_vf) @@ -684,6 +675,7 @@ contains call cpu_time(finish) end subroutine s_apply_initial_condition + !> @brief Gathers processor timing data and writes elapsed wall-clock time to a summary file. impure subroutine s_save_data(proc_time, time_avg, time_final, file_exists) real(wp), dimension(:), intent(inout) :: proc_time @@ -717,6 +709,7 @@ contains end if end if end subroutine s_save_data + !> @brief Initializes MPI, reads and validates user inputs on rank 0, and decomposes the computational domain. impure subroutine s_initialize_mpi_domain ! Initialization of the MPI environment @@ -743,6 +736,7 @@ contains call s_initialize_parallel_io() call s_mpi_decompose_computational_domain() end subroutine s_initialize_mpi_domain + !> @brief Finalizes all pre-process modules, deallocates resources, and shuts down MPI. impure subroutine s_finalize_modules ! Disassociate pointers for serial and parallel I/O diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index c2937ce0ff..618488b223 100644 --- a/src/pre_process/p_main.f90 +++ b/src/pre_process/p_main.f90 @@ -5,7 +5,6 @@ !> @brief This program takes care of setting up the initial condition and grid data for the multicomponent flow code. program p_main use m_global_parameters !< Global parameters for the code - use m_start_up implicit none diff --git a/src/simulation/include/inline_riemann.fpp b/src/simulation/include/inline_riemann.fpp index aae4015292..ede9e7b8d3 100644 --- a/src/simulation/include/inline_riemann.fpp +++ b/src/simulation/include/inline_riemann.fpp @@ -51,7 +51,7 @@ ! Case when T_L and T_R are very close Cp_avg = sum(Yi_avg(:)*(0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights_nonparameter(:)) Cv_avg = sum(Yi_avg(:)*((0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights_nonparameter(:) & - & - gas_constant/molecular_weights_nonparameter(:))) + & - gas_constant/molecular_weights_nonparameter(:))) else ! Normal calculation when T_L and T_R are sufficiently different Cp_avg = sum(Yi_avg(:)*(h_iR(:) - h_iL(:))/(T_R - T_L)) @@ -60,14 +60,14 @@ gamma_avg = Cp_avg/Cv_avg Phi_avg(:) = (gamma_avg - 1._wp)*(vel_avg_rms/2.0_wp - h_avg_2(:)) & - & + gamma_avg*gas_constant/molecular_weights_nonparameter(:)*T_avg + & + gamma_avg*gas_constant/molecular_weights_nonparameter(:)*T_avg c_sum_Yi_Phi = sum(Yi_avg(:)*Phi_avg(:)) #:else if (abs(T_L - T_R) < eps) then ! Case when T_L and T_R are very close Cp_avg = sum(Yi_avg(:)*(0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights(:)) Cv_avg = sum(Yi_avg(:)*((0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights(:) & - & - gas_constant/molecular_weights(:))) + & - gas_constant/molecular_weights(:))) else ! Normal calculation when T_L and T_R are sufficiently different Cp_avg = sum(Yi_avg(:)*(h_iR(:) - h_iL(:))/(T_R - T_L)) @@ -105,7 +105,7 @@ if (low_Mach == 1) then pcorr = rho_L*rho_R*(s_L - vel_L(dir_idx(1)))*(s_R - vel_R(dir_idx(1)))*(vel_R(dir_idx(1)) - vel_L(dir_idx(1))) & - & /(rho_R*(s_R - vel_R(dir_idx(1))) - rho_L*(s_L - vel_L(dir_idx(1))))*(zcoef - 1._wp) + & /(rho_R*(s_R - vel_R(dir_idx(1))) - rho_L*(s_L - vel_L(dir_idx(1))))*(zcoef - 1._wp) else if (low_Mach == 2) then vel_L_tmp = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + zcoef*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) vel_R_tmp = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + zcoef*(vel_R(dir_idx(1)) - vel_L(dir_idx(1)))) diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 6e2f4d821f..1c2b644ba5 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -7,15 +7,10 @@ !> @brief Applies acoustic pressure source terms including focused, planar, and broadband transducers module m_acoustic_src use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_bubbles !< Bubble dynamic routines - use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers - use m_constants !< Definitions of the constants implicit none @@ -66,11 +61,12 @@ contains integer :: i, j !< generic loop variables @:ALLOCATE(loc_acoustic(1:3, 1:num_source), mag(1:num_source), dipole(1:num_source), support(1:num_source), & - & length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), & - & gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), & - & aperture(1:num_source), npulse(1:num_source), pulse(1:num_source), dir(1:num_source), delay(1:num_source), & - & element_polygon_ratio(1:num_source), rotate_angle(1:num_source), element_spacing_angle(1:num_source), & - & num_elements(1:num_source), element_on(1:num_source), bb_num_freq(1:num_source), bb_bandwidth(1:num_source), bb_lowest_freq(1:num_source)) + & length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), & + & gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), aperture(1:num_source), & + & npulse(1:num_source), pulse(1:num_source), dir(1:num_source), delay(1:num_source), & + & element_polygon_ratio(1:num_source), rotate_angle(1:num_source), element_spacing_angle(1:num_source), & + & num_elements(1:num_source), element_on(1:num_source), bb_num_freq(1:num_source), bb_bandwidth(1:num_source), & + & bb_lowest_freq(1:num_source)) do i = 1, num_source do j = 1, 3 @@ -113,15 +109,15 @@ contains delay(i) = acoustic(i)%delay end if end do - $:GPU_UPDATE(device='[loc_acoustic,mag,dipole,support,length, & - & height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, & - & element_polygon_ratio, rotate_angle, element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, & - & bb_lowest_freq]') + $:GPU_UPDATE(device='[loc_acoustic, mag, dipole, support, length, height, wavelength, frequency, gauss_sigma_dist, & + & gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, element_polygon_ratio, rotate_angle, & + & element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, bb_lowest_freq]') @:ALLOCATE(mass_src(0:m, 0:n, 0:p)) @:ALLOCATE(mom_src(1:num_vels, 0:m, 0:n, 0:p)) @:ALLOCATE(E_src(0:m, 0:n, 0:p)) end subroutine s_initialize_acoustic_src + !> This subroutine updates the rhs by computing the mass, mom, energy sources !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables @@ -141,13 +137,13 @@ contains real(wp) :: frequency_local, gauss_sigma_time_local real(wp) :: mass_src_diff, mom_src_diff real(wp) :: source_temporal - real(wp) :: period_BB !< period of each sine wave in broadband source - real(wp) :: sl_BB !< spectral level at each frequency - real(wp) :: ffre_BB !< source term corresponding to each frequency - real(wp) :: sum_BB !< total source term for the broadband wave - real(wp), allocatable, dimension(:) :: phi_rn !< random phase shift for each frequency + real(wp) :: period_BB !< period of each sine wave in broadband source + real(wp) :: sl_BB !< spectral level at each frequency + real(wp) :: ffre_BB !< source term corresponding to each frequency + real(wp) :: sum_BB !< total source term for the broadband wave + real(wp), allocatable, dimension(:) :: phi_rn !< random phase shift for each frequency integer :: i, j, k, l, q !< generic loop variables - integer :: ai !< acoustic source index + integer :: ai !< acoustic source index integer :: num_points logical :: freq_conv_flag, gauss_conv_flag integer, parameter :: mass_label = 1, mom_label = 2 @@ -259,7 +255,7 @@ contains ! Update momentum source term call s_source_temporal(sim_time, c, ai, mom_label, frequency_local, gauss_sigma_time_local, source_temporal, & - & sum_BB) + & sum_BB) mom_src_diff = source_temporal*source_spatials(ai)%val(i) if (dipole(ai)) then ! Double amplitude & No momentum source term (only works for Planar) @@ -296,7 +292,7 @@ contains ! Mass source term must be calculated differently using a correction term for spherical and cylindrical ! support call s_source_temporal(sim_time, c, ai, mass_label, frequency_local, gauss_sigma_time_local, & - & source_temporal, sum_BB) + & source_temporal, sum_BB) mass_src_diff = source_temporal*source_spatials(ai)%val(i) end if mass_src(j, k, l) = mass_src(j, k, l) + mass_src_diff @@ -329,6 +325,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_acoustic_src_calculations + !> This subroutine gives the temporally varying amplitude of the pulse !! @param sim_time Simulation time !! @param c Sound speed @@ -374,7 +371,7 @@ contains if (term_index == mass_label) then source = source/c - foc_length_factor*mag(ai)*sqrt(pi/2)*gauss_sigma_time_local*(erf((sim_time - delay(ai)) & - & /(sqrt(2._wp)*gauss_sigma_time_local)) + 1) + & /(sqrt(2._wp)*gauss_sigma_time_local)) + 1) end if else if (pulse(ai) == 3) then ! Square wave if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return @@ -391,6 +388,7 @@ contains source = sum_BB end if end subroutine s_source_temporal + !> This subroutine identifies and precalculates the non-zero acoustic spatial sources before time-stepping impure subroutine s_precalculate_acoustic_spatial_sources integer :: j, k, l, ai @@ -472,10 +470,11 @@ contains #ifdef MFC_DEBUG do ai = 1, num_source write (*, '(A,I2,A,I8,A)') 'Acoustic source ', ai, ' has ', source_spatials_num_points(ai), & - & ' grid points with non-zero source term' + & ' grid points with non-zero source term' end do #endif end subroutine s_precalculate_acoustic_spatial_sources + !> This subroutine gives the spatial support of the acoustic source !! @param j x-index !! @param k y-index @@ -514,6 +513,7 @@ contains call s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios) end if end subroutine s_source_spatial + !> This subroutine calculates the spatial support for planar acoustic sources in 1D, 2D, and 3D !! @param ai Acoustic source index !! @param sig Sigma value for the Gaussian distribution @@ -540,6 +540,7 @@ contains end if end if end subroutine s_source_spatial_planar + !> This subroutine calculates the spatial support for a single transducer in 2D, 2D axisymmetric, and 3D !! @param ai Acoustic source index !! @param sig Sigma value for the Gaussian distribution @@ -581,6 +582,7 @@ contains end if end if end subroutine s_source_spatial_transducer + !> This subroutine calculates the spatial support for multiple transducers in 2D, 2D axisymmetric, and 3D !! @param ai Acoustic source index !! @param sig Sigma value for the Gaussian distribution @@ -660,6 +662,7 @@ contains end do end if end subroutine s_source_spatial_transducer_array + !> This function performs wavelength to frequency conversion !! @param freq_conv_flag Determines if frequency is given or wavelength !! @param ai Acoustic source index @@ -678,6 +681,7 @@ contains f_frequency_local = frequency(ai) end if end function f_frequency_local + !> This function performs Gaussian sigma dist to time conversion !! @param gauss_conv_flag Determines if sigma_dist is given or sigma_time !! @param c Speed of sound diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index 5cd48f0a28..630ffc017b 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -7,11 +7,8 @@ !> @brief Computes gravitational and user-defined body force source terms for the momentum equations module m_body_forces use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion - use m_nvtx ! $:USE_GPU_MODULE() @@ -41,6 +38,7 @@ contains @:ALLOCATE(rhoM(-buff_size:buff_size + m, 0:0, 0:0)) end if end subroutine s_initialize_body_forces_module + !> This subroutine computes the acceleration at time t subroutine s_compute_acceleration(t) real(wp), intent(in) :: t @@ -53,6 +51,7 @@ contains $:GPU_UPDATE(device='[accel_bf]') end subroutine s_compute_acceleration + !> This subroutine calculates the mixture density at each cell center !! @param q_cons_vf Conservative variables subroutine s_compute_mixture_density(q_cons_vf) @@ -72,6 +71,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_compute_mixture_density + !> This subroutine calculates the source term due to body forces so the system can be advanced in time !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables @@ -139,6 +139,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_compute_body_forces_rhs + !> @brief Deallocates module variables used for body force computations. impure subroutine s_finalize_body_forces_module @:DEALLOCATE(rhoM) diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index f0957e44b5..d50e4b926e 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -8,20 +8,16 @@ !! models module m_bubbles use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers implicit none - real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) - real(wp) :: k_mw !< Bubble wall properties (Ando 2010) - real(wp) :: rho_mw !< Bubble wall properties (Ando 2010) + real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) + real(wp) :: k_mw !< Bubble wall properties (Ando 2010) + real(wp) :: rho_mw !< Bubble wall properties (Ando 2010) $:GPU_DECLARE(create='[chi_vw, k_mw, rho_mw]') contains @@ -75,6 +71,7 @@ contains f_rddot = 0._wp end if end function f_rddot + !> Function that computes that bubble wall pressure for Gilmore bubbles !! @param fR0 Equilibrium bubble radius !! @param fR Current bubble radius @@ -91,6 +88,7 @@ contains f_cpbw = fpb - 1._wp - 4._wp*Re_inv*fV/fR - 2._wp/(fR*Web) end if end function f_cpbw + !> Function that computes the bubble enthalpy !! @param fCpbw Bubble wall pressure !! @param fCpinf Driving bubble pressure @@ -108,6 +106,7 @@ contains f_H = (tmp2 - tmp3)*fntait*(1._wp + fBtait)/(fntait - 1._wp) end function f_H + !> Function that computes the sound speed for the bubble !! @param fCpinf Driving bubble pressure !! @param fntait Tait EOS parameter @@ -125,6 +124,7 @@ contains f_cgas = sqrt(tmp + (fntait - 1._wp)*fH) end function f_cgas + !> Function that computes the time derivative of the driving pressure !! @param fRho Local liquid density !! @param fP Local pressure @@ -150,6 +150,7 @@ contains ! \dot{Cp_inf} = rho sound^2 (alf_src - divu) f_cpinfdot = fRho*c2_liquid*(advsrc - divu) end function f_cpinfdot + !> Function that computes the time derivative of the enthalpy !! @param fCpbw Bubble wall pressure !! @param fCpinf Driving bubble pressure @@ -176,7 +177,7 @@ contains tmp2 = (2._wp/Web + 4._wp*Re_inv*fV)*fV/(fR**2._wp) f_Hdot = (fCpbw/(1._wp + fBtait) + 1._wp)**(-1._wp/fntait)*(tmp1 + tmp2) - (fCpinf/(1._wp + fBtait) + 1._wp) & - & **(-1._wp/fntait)*fCpinf_dot + & **(-1._wp/fntait)*fCpinf_dot ! Hdot = (Cpbw/(1+B) + 1)^(-1/n_tait)*(-3 gam)*(R0/R)^(3gam) V/R ! f_Hdot = ((fCpbw/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*(-3._wp)*gam * & @@ -185,6 +186,7 @@ contains ! Hdot = Hdot - (Cpinf/(1+B) + 1)^(-1/n_tait) Cpinfdot ! f_Hdot = f_Hdot - ((fCpinf/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*fCpinf_dot end function f_Hdot + !> Function that computes the bubble radial acceleration for Rayleigh-Plesset bubbles !! @param fCp Driving pressure !! @param fRho Current density @@ -202,6 +204,7 @@ contains f_rddot_RP = (-1.5_wp*(fV**2._wp) + (fCpbw - fCp)/fRho)/fR end function f_rddot_RP + !> Function that computes the bubble radial acceleration !! @param fCpbw Bubble wall pressure !! @param fR Current bubble radius @@ -224,6 +227,7 @@ contains f_rddot_G = tmp3/(fR*(1._wp - tmp1)*tmp2) end function f_rddot_G + !> Function that computes the bubble wall pressure for Keller--Miksis bubbles !! @param fR0 Equilibrium bubble radius !! @param fR Current bubble radius @@ -244,6 +248,7 @@ contains if (.not. f_is_default(Web)) f_cpbw_KM = f_cpbw_KM - 2._wp/(fR*Web) if (.not. f_is_default(Re_inv)) f_cpbw_KM = f_cpbw_KM - 4._wp*Re_inv*fV/fR end function f_cpbw_KM + !> Function that computes the bubble radial acceleration for Keller--Miksis bubbles !! @param fpbdot Time-derivative of internal bubble pressure !! @param fCp Driving pressure @@ -278,6 +283,7 @@ contains f_rddot_KM = tmp2/(fR*(1._wp - tmp1) + 4._wp*Re_inv/(fRho*fC)) end if end function f_rddot_KM + !> Subroutine that computes bubble wall properties for vapor bubbles !! @param pb_in Internal bubble pressure !! @param iR0 Current bubble size index @@ -285,9 +291,9 @@ contains $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: pb_in integer, intent(in) :: iR0 - real(wp), intent(out) :: chi_vw_out !< Bubble wall properties (Ando 2010) - real(wp), intent(out) :: k_mw_out !< Bubble wall properties (Ando 2010) - real(wp), intent(out) :: rho_mw_out !< Bubble wall properties (Ando 2010) + real(wp), intent(out) :: chi_vw_out !< Bubble wall properties (Ando 2010) + real(wp), intent(out) :: k_mw_out !< Bubble wall properties (Ando 2010) + real(wp), intent(out) :: rho_mw_out !< Bubble wall properties (Ando 2010) real(wp) :: x_vw ! mass fraction of vapor @@ -298,6 +304,7 @@ contains ! gas mixture density rho_mw_out = pv/(chi_vw_out*R_v*Tw) end subroutine s_bwproperty + !> Function that computes the vapour flux !! @param fR Current bubble radius !! @param fV Current bubble velocity @@ -353,6 +360,7 @@ contains vflux = pv*fV/(R_v*Tw) end if end subroutine s_vflux + !> Function that computes the time derivative of the internal bubble pressure !! @param fvflux Vapour flux !! @param fR Current bubble radius @@ -386,12 +394,13 @@ contains return end if grad_T = -Re_trans_T(iR0)*((fpb/pb0(iR0))*(fR/R0(iR0))**3*(mass_g0(iR0) + mass_v0(iR0))/(mass_g0(iR0) + fmass_v) & - & - 1._wp) + & - 1._wp) f_bpres_dot = 3._wp*gam_m*(-fV*fpb + fvflux*R_v*Tw + pb0(iR0)*k_mw*grad_T/Pe_T(iR0)/fR)/fR else f_bpres_dot = -3._wp*gam_m*fV/fR*(fpb - pv) end if end function f_bpres_dot + !> Adaptive time stepping routine for subgrid bubbles (See Heirer, E. Hairer S.P.Norsett G. Wanner, Solving Ordinary !! Differential Equations I, Chapter II.4) !! @param fRho Current density @@ -414,7 +423,7 @@ contains !! @param fCson Speed of sound (EL) !! @param adap_dt_stop Fail-safe exit if max iteration count reached subroutine s_advance_step(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, bub_id, fmass_v, & - & fmass_g, fbeta_c, fbeta_t, fCson, adap_dt_stop) + & fmass_g, fbeta_c, fbeta_t, fCson, adap_dt_stop) $:GPU_ROUTINE(function_name='s_advance_step',parallelism='[seq]', cray_inline=True) real(wp), intent(inout) :: fR, fV, fpb, fmass_v @@ -423,11 +432,11 @@ contains integer, intent(in) :: bub_id real(wp), intent(in) :: fmass_g, fbeta_c, fbeta_t, fCson integer, intent(inout) :: adap_dt_stop - real(wp), dimension(5) :: err !< Error estimates for adaptive time stepping + real(wp), dimension(5) :: err !< Error estimates for adaptive time stepping real(wp) :: t_new !< Updated time step size real(wp) :: h0, h !< Time step size real(wp), dimension(4) :: myR_tmp1, myV_tmp1, myR_tmp2, & - & myV_tmp2 !< Bubble radius, radial velocity, and radial acceleration for the inner loop + & myV_tmp2 !< Bubble radius, radial velocity, and radial acceleration for the inner loop real(wp), dimension(4) :: myPb_tmp1, myMv_tmp1, myPb_tmp2, myMv_tmp2 !< Gas pressure and vapor mass for the inner loop (EL) real(wp) :: fR2, fV2, fpb2, fmass_v2 integer :: iter_count @@ -450,8 +459,7 @@ contains ! Advance one sub-step call s_advance_substep(err(1), fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & - & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp1, myV_tmp1, myPb_tmp1, & - & myMv_tmp1) + & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp1, myV_tmp1, myPb_tmp1, myMv_tmp1) if (err(1) > adap_dt_tol) then h = 0.25_wp*h cycle @@ -459,8 +467,7 @@ contains ! Advance one sub-step by advancing two half steps call s_advance_substep(err(2), fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & - & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, & - & myPb_tmp2, myMv_tmp2) + & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, myPb_tmp2, myMv_tmp2) if (err(2) > adap_dt_tol) then h = 0.25_wp*h cycle @@ -470,8 +477,7 @@ contains fpb2 = myPb_tmp2(4); fmass_v2 = myMv_tmp2(4) call s_advance_substep(err(3), fRho, fP, fR2, fV2, fR0, fpb2, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & - & bub_id, fmass_v2, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, & - & myPb_tmp2, myMv_tmp2) + & bub_id, fmass_v2, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, myPb_tmp2, myMv_tmp2) if (err(3) > adap_dt_tol) then h = 0.5_wp*h cycle @@ -521,6 +527,7 @@ contains if (iter_count >= adap_dt_max_iters) adap_dt_stop = 1 end subroutine s_advance_step + !> Choose the initial time step size for the adaptive time stepping routine (See Heirer, E. Hairer S.P.Norsett G. Wanner, !! Solving Ordinary Differential Equations I, Chapter II.4) !! @param fRho Current density @@ -544,8 +551,8 @@ contains real(wp), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu real(wp), intent(in) :: fCson real(wp), intent(out) :: h - real(wp), dimension(2) :: h_size !< Time step size (h0, h1) - real(wp), dimension(3) :: d_norms !< norms (d_0, d_1, d_2) + real(wp), dimension(2) :: h_size !< Time step size (h0, h1) + real(wp), dimension(3) :: d_norms !< norms (d_0, d_1, d_2) real(wp), dimension(2) :: myR_tmp, myV_tmp, myA_tmp !< Bubble radius, radial velocity, and radial acceleration ! Determine the starting time step @@ -581,6 +588,7 @@ contains h = min(h_size(1)/scale_guess, h_size(2)) end subroutine s_initial_substep_h + !> Integrate bubble variables over the given time step size, h, using a third-order accurate embedded Runge-Kutta scheme. !! @param err Estimated error !! @param fRho Current density @@ -607,7 +615,7 @@ contains !! @param myPb_tmp Internal bubble pressure at each stage (EL) !! @param myMv_tmp Mass of vapor in the bubble at each stage (EL) subroutine s_advance_substep(err, fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, bub_id, & - & fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp, myV_tmp, myPb_tmp, myMv_tmp) + & fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp, myV_tmp, myPb_tmp, myMv_tmp) $:GPU_ROUTINE(function_name='s_advance_substep',parallelism='[seq]', cray_inline=True) real(wp), intent(out) :: err @@ -629,10 +637,10 @@ contains myPb_tmp(1) = fpb myMv_tmp(1) = fmass_v call s_advance_EL(myR_tmp(1), myV_tmp(1), myPb_tmp(1), myMv_tmp(1), bub_id, fmass_g, fbeta_c, fbeta_t, & - & mydPbdt_tmp(1), mydMvdt_tmp(1)) + & mydPbdt_tmp(1), mydMvdt_tmp(1)) end if myA_tmp(1) = f_rddot(fRho, fP, myR_tmp(1), myV_tmp(1), fR0, myPb_tmp(1), mydPbdt_tmp(1), alf, fntait, fBtait, & - & f_bub_adv_src, f_divu, fCson) + & f_bub_adv_src, f_divu, fCson) ! Stage 1 myR_tmp(2) = myR_tmp(1) + h*myV_tmp(1) @@ -644,10 +652,10 @@ contains myPb_tmp(2) = myPb_tmp(1) + h*mydPbdt_tmp(1) myMv_tmp(2) = myMv_tmp(1) + h*mydMvdt_tmp(1) call s_advance_EL(myR_tmp(2), myV_tmp(2), myPb_tmp(2), myMv_tmp(2), bub_id, fmass_g, fbeta_c, fbeta_t, & - & mydPbdt_tmp(2), mydMvdt_tmp(2)) + & mydPbdt_tmp(2), mydMvdt_tmp(2)) end if myA_tmp(2) = f_rddot(fRho, fP, myR_tmp(2), myV_tmp(2), fR0, myPb_tmp(2), mydPbdt_tmp(2), alf, fntait, fBtait, & - & f_bub_adv_src, f_divu, fCson) + & f_bub_adv_src, f_divu, fCson) ! Stage 2 myR_tmp(3) = myR_tmp(1) + (h/4._wp)*(myV_tmp(1) + myV_tmp(2)) @@ -659,10 +667,10 @@ contains myPb_tmp(3) = myPb_tmp(1) + (h/4._wp)*(mydPbdt_tmp(1) + mydPbdt_tmp(2)) myMv_tmp(3) = myMv_tmp(1) + (h/4._wp)*(mydMvdt_tmp(1) + mydMvdt_tmp(2)) call s_advance_EL(myR_tmp(3), myV_tmp(3), myPb_tmp(3), myMv_tmp(3), bub_id, fmass_g, fbeta_c, fbeta_t, & - & mydPbdt_tmp(3), mydMvdt_tmp(3)) + & mydPbdt_tmp(3), mydMvdt_tmp(3)) end if myA_tmp(3) = f_rddot(fRho, fP, myR_tmp(3), myV_tmp(3), fR0, myPb_tmp(3), mydPbdt_tmp(3), alf, fntait, fBtait, & - & f_bub_adv_src, f_divu, fCson) + & f_bub_adv_src, f_divu, fCson) ! Stage 3 myR_tmp(4) = myR_tmp(1) + (h/6._wp)*(myV_tmp(1) + myV_tmp(2) + 4._wp*myV_tmp(3)) @@ -674,10 +682,10 @@ contains myPb_tmp(4) = myPb_tmp(1) + (h/6._wp)*(mydPbdt_tmp(1) + mydPbdt_tmp(2) + 4._wp*mydPbdt_tmp(3)) myMv_tmp(4) = myMv_tmp(1) + (h/6._wp)*(mydMvdt_tmp(1) + mydMvdt_tmp(2) + 4._wp*mydMvdt_tmp(3)) call s_advance_EL(myR_tmp(4), myV_tmp(4), myPb_tmp(4), myMv_tmp(4), bub_id, fmass_g, fbeta_c, fbeta_t, & - & mydPbdt_tmp(4), mydMvdt_tmp(4)) + & mydPbdt_tmp(4), mydMvdt_tmp(4)) end if myA_tmp(4) = f_rddot(fRho, fP, myR_tmp(4), myV_tmp(4), fR0, myPb_tmp(4), mydPbdt_tmp(4), alf, fntait, fBtait, & - & f_bub_adv_src, f_divu, fCson) + & f_bub_adv_src, f_divu, fCson) ! Estimate error err_R = (-5._wp*h/24._wp)*(myV_tmp(2) + myV_tmp(3) - 2._wp*myV_tmp(4))/max(abs(myR_tmp(1)), abs(myR_tmp(4))) @@ -692,6 +700,7 @@ contains end if err = sqrt((err_R**2._wp + err_V**2._wp)/2._wp) end subroutine s_advance_substep + !> Changes of pressure and vapor mass in the lagrange bubbles. !! @param fR_tmp Bubble radius !! @param fV_tmp Bubble radial velocity diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index 6a5131ad62..7a14035a93 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -7,13 +7,9 @@ !> @brief Computes ensemble-averaged (Euler--Euler) bubble source terms for radius, velocity, pressure, and mass transfer module m_bubbles_EE use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_bubbles !< General bubble dynamics procedures implicit none @@ -64,6 +60,7 @@ contains if (adap_dt .and. f_is_default(adap_dt_tol)) adap_dt_tol = dflt_adap_dt_tol end subroutine s_initialize_bubbles_EE_module + !> @brief Computes the bubble volume fraction alpha from the bubble number density. !! @param q_cons_vf is the conservative variable subroutine s_comp_alpha_from_n(q_cons_vf) @@ -86,6 +83,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_comp_alpha_from_n + !> Compute the right-hand side for Euler-Euler bubble transport !! @param idir Direction index !! @param q_prim_vf Primitive variables @@ -103,7 +101,7 @@ contains do j = 0, m divu_in%sf(j, k, l) = 0._wp divu_in%sf(j, k, l) = 5.e-1_wp/dx(j)*(q_prim_vf(contxe + idir)%sf(j + 1, k, & - & l) - q_prim_vf(contxe + idir)%sf(j - 1, k, l)) + & l) - q_prim_vf(contxe + idir)%sf(j - 1, k, l)) end do end do end do @@ -115,7 +113,7 @@ contains do k = 0, n do j = 0, m divu_in%sf(j, k, l) = divu_in%sf(j, k, l) + 5.e-1_wp/dy(k)*(q_prim_vf(contxe + idir)%sf(j, k + 1, & - & l) - q_prim_vf(contxe + idir)%sf(j, k - 1, l)) + & l) - q_prim_vf(contxe + idir)%sf(j, k - 1, l)) end do end do end do @@ -126,13 +124,14 @@ contains do k = 0, n do j = 0, m divu_in%sf(j, k, l) = divu_in%sf(j, k, l) + 5.e-1_wp/dz(l)*(q_prim_vf(contxe + idir)%sf(j, k, & - & l + 1) - q_prim_vf(contxe + idir)%sf(j, k, l - 1)) + & l + 1) - q_prim_vf(contxe + idir)%sf(j, k, l - 1)) end do end do end do $:END_GPU_PARALLEL_LOOP() end if end subroutine s_compute_bubbles_EE_rhs + !> The purpose of this procedure is to compute the source terms that are needed for the bubble modeling !! @param q_prim_vf Primitive variables !! @param q_cons_vf Conservative variables @@ -153,11 +152,11 @@ contains real(wp), dimension(num_fluids) :: myalpha, myalpha_rho #:endif real(wp) :: myR, myV, alf, myP, myRho, R2Vav, R3 - real(wp) :: nbub !< Bubble number density + real(wp) :: nbub !< Bubble number density real(wp) :: my_divu - integer :: i, j, k, l, q, ii !< Loop variables + integer :: i, j, k, l, q, ii !< Loop variables integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached - integer :: dmBub_id !< Dummy variables for unified subgrid bubble subroutines + integer :: dmBub_id !< Dummy variables for unified subgrid bubble subroutines real(wp) :: dmMass_v, dmMass_n, dmBeta_c, dmBeta_t, dmCson $:GPU_PARALLEL_LOOP(private='[j, k, l, q]', collapse=3) @@ -274,8 +273,8 @@ contains adap_dt_stop = 0 call s_advance_step(myRho, myP, myR, myV, R0(q), pb_local, pbdot, alf, n_tait, B_tait, & - & bub_adv_src(j, k, l), divu_in%sf(j, k, l), dmBub_id, dmMass_v, dmMass_n, & - & dmBeta_c, dmBeta_t, dmCson, adap_dt_stop) + & bub_adv_src(j, k, l), divu_in%sf(j, k, l), dmBub_id, dmMass_v, dmMass_n, dmBeta_c, & + & dmBeta_t, dmCson, adap_dt_stop) q_cons_vf(rs(q))%sf(j, k, l) = nbub*myR q_cons_vf(vs(q))%sf(j, k, l) = nbub*myV @@ -283,7 +282,7 @@ contains adap_dt_stop_max = max(adap_dt_stop_max, adap_dt_stop) else rddot = f_rddot(myRho, myP, myR, myV, R0(q), pb_local, pbdot, alf, n_tait, B_tait, bub_adv_src(j, & - & k, l), divu_in%sf(j, k, l), dmCson) + & k, l), divu_in%sf(j, k, l), dmCson) bub_v_src(j, k, l, q) = nbub*rddot bub_r_src(j, k, l, q) = q_cons_vf(vs(q))%sf(j, k, l) end if diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 09a672ba4c..3bf2fa7e18 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -7,45 +7,36 @@ !> @brief Tracks Lagrangian bubbles and couples their dynamics to the Eulerian flow via volume averaging module m_bubbles_EL use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_bubbles_EL_kernels !< Definitions of the kernel functions - use m_bubbles !< General bubble dynamics procedures - use m_variables_conversion !< State variables type conversion procedures - use m_compile_specific - use m_boundary_common - use m_helper_basic !< Functions to compare floating point numbers - use m_sim_helpers - use m_helper implicit none ! (nBub) - integer, allocatable, dimension(:,:) :: lag_id !< Global and local IDs - real(wp), allocatable, dimension(:) :: bub_R0 !< Initial bubble radius - real(wp), allocatable, dimension(:) :: Rmax_stats !< Maximum radius - real(wp), allocatable, dimension(:) :: Rmin_stats !< Minimum radius + integer, allocatable, dimension(:,:) :: lag_id !< Global and local IDs + real(wp), allocatable, dimension(:) :: bub_R0 !< Initial bubble radius + real(wp), allocatable, dimension(:) :: Rmax_stats !< Maximum radius + real(wp), allocatable, dimension(:) :: Rmin_stats !< Minimum radius $:GPU_DECLARE(create='[lag_id, bub_R0, Rmax_stats, Rmin_stats]') - real(wp), allocatable, dimension(:) :: gas_mg !< Bubble's gas mass - real(wp), allocatable, dimension(:) :: gas_betaT !< heatflux model (Preston et al., 2007) - real(wp), allocatable, dimension(:) :: gas_betaC !< massflux model (Preston et al., 2007) - real(wp), allocatable, dimension(:) :: bub_dphidt !< subgrid velocity potential (Maeda & Colonius, 2018) + real(wp), allocatable, dimension(:) :: gas_mg !< Bubble's gas mass + real(wp), allocatable, dimension(:) :: gas_betaT !< heatflux model (Preston et al., 2007) + real(wp), allocatable, dimension(:) :: gas_betaC !< massflux model (Preston et al., 2007) + real(wp), allocatable, dimension(:) :: bub_dphidt !< subgrid velocity potential (Maeda & Colonius, 2018) $:GPU_DECLARE(create='[gas_mg, gas_betaT, gas_betaC, bub_dphidt]') ! (nBub, 1 -> actual val or 2 -> temp val) - real(wp), allocatable, dimension(:,:) :: gas_p !< Pressure in the bubble - real(wp), allocatable, dimension(:,:) :: gas_mv !< Vapor mass in the bubble - real(wp), allocatable, dimension(:,:) :: intfc_rad !< Bubble radius - real(wp), allocatable, dimension(:,:) :: intfc_vel !< Velocity of the bubble interface + real(wp), allocatable, dimension(:,:) :: gas_p !< Pressure in the bubble + real(wp), allocatable, dimension(:,:) :: gas_mv !< Vapor mass in the bubble + real(wp), allocatable, dimension(:,:) :: intfc_rad !< Bubble radius + real(wp), allocatable, dimension(:,:) :: intfc_vel !< Velocity of the bubble interface $:GPU_DECLARE(create='[gas_p, gas_mv, intfc_rad, intfc_vel]') ! (nBub, 1-> x or 2->y or 3 ->z, 1 -> actual or 2 -> temporal val) real(wp), allocatable, dimension(:,:,:) :: mtn_pos !< Bubble's position @@ -54,20 +45,20 @@ module m_bubbles_EL real(wp), allocatable, dimension(:,:,:) :: mtn_s !< Bubble's computational cell position in real format $:GPU_DECLARE(create='[mtn_pos, mtn_posPrev, mtn_vel, mtn_s]') ! (nBub, 1-> x or 2->y or 3 ->z, time-stage) - real(wp), allocatable, dimension(:,:) :: intfc_draddt !< Time derivative of bubble's radius - real(wp), allocatable, dimension(:,:) :: intfc_dveldt !< Time derivative of bubble's interface velocity - real(wp), allocatable, dimension(:,:) :: gas_dpdt !< Time derivative of gas pressure - real(wp), allocatable, dimension(:,:) :: gas_dmvdt !< Time derivative of the vapor mass in the bubble - real(wp), allocatable, dimension(:,:,:) :: mtn_dposdt !< Time derivative of the bubble's position - real(wp), allocatable, dimension(:,:,:) :: mtn_dveldt !< Time derivative of the bubble's velocity + real(wp), allocatable, dimension(:,:) :: intfc_draddt !< Time derivative of bubble's radius + real(wp), allocatable, dimension(:,:) :: intfc_dveldt !< Time derivative of bubble's interface velocity + real(wp), allocatable, dimension(:,:) :: gas_dpdt !< Time derivative of gas pressure + real(wp), allocatable, dimension(:,:) :: gas_dmvdt !< Time derivative of the vapor mass in the bubble + real(wp), allocatable, dimension(:,:,:) :: mtn_dposdt !< Time derivative of the bubble's position + real(wp), allocatable, dimension(:,:,:) :: mtn_dveldt !< Time derivative of the bubble's velocity $:GPU_DECLARE(create='[intfc_draddt, intfc_dveldt, gas_dpdt, gas_dmvdt, mtn_dposdt, mtn_dveldt]') integer, private :: lag_num_ts !< Number of time stages in the time-stepping scheme $:GPU_DECLARE(create='[lag_num_ts]') - integer :: nBubs !< Number of bubbles in the local domain - real(wp) :: Rmax_glb, Rmin_glb !< Maximum and minimum bubbe size in the local domain + integer :: nBubs !< Number of bubbles in the local domain + real(wp) :: Rmax_glb, Rmin_glb !< Maximum and minimum bubbe size in the local domain !< Projection of the lagrangian particles in the Eulerian framework type(scalar_field), dimension(:), allocatable :: q_beta integer :: q_beta_idx !< Size of the q_beta vector field @@ -142,6 +133,7 @@ contains ! Starting bubbles call s_read_input_bubbles(q_cons_vf) end subroutine s_initialize_bubbles_EL_module + !> The purpose of this procedure is to obtain the initial bubbles' information !! @param q_cons_vf Conservative variables impure subroutine s_read_input_bubbles(q_cons_vf) @@ -200,9 +192,9 @@ contains $:GPU_UPDATE(device='[bubbles_lagrange, lag_params]') - $:GPU_UPDATE(device='[lag_id,bub_R0,Rmax_stats,Rmin_stats,gas_mg, & - & gas_betaT, gas_betaC, bub_dphidt, gas_p, gas_mv, intfc_rad, intfc_vel, mtn_pos, mtn_posPrev, mtn_vel, mtn_s, & - & intfc_draddt, intfc_dveldt, gas_dpdt, gas_dmvdt, mtn_dposdt, mtn_dveldt, nBubs]') + $:GPU_UPDATE(device='[lag_id, bub_R0, Rmax_stats, Rmin_stats, gas_mg, gas_betaT, gas_betaC, bub_dphidt, gas_p, gas_mv, & + & intfc_rad, intfc_vel, mtn_pos, mtn_posPrev, mtn_vel, mtn_s, intfc_draddt, intfc_dveldt, gas_dpdt, gas_dmvdt, & + & mtn_dposdt, mtn_dveldt, nBubs]') Rmax_glb = min(dflt_real, -dflt_real) Rmin_glb = max(dflt_real, -dflt_real) @@ -225,6 +217,7 @@ contains call s_write_void_evol(qtime) end if end subroutine s_read_input_bubbles + !> The purpose of this procedure is to obtain the information of the bubbles when starting fresh !! @param inputBubble Bubble information !! @param q_cons_vf Conservative variables @@ -333,6 +326,7 @@ contains call s_mpi_abort("Negative gas mass in the bubble, check if the bubble is in the domain.") end if end subroutine s_add_bubbles + !> The purpose of this procedure is to obtain the information of the bubbles from a restart point. !! @param bub_id Local ID of the particle !! @param save_count File identifier @@ -427,7 +421,7 @@ contains ! Skip extended header disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lag_bubbles, lag_io_vars*bub_id, mpi_p, status, ierr) @@ -468,7 +462,7 @@ contains ! Skip extended header disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -485,6 +479,7 @@ contains deallocate (proc_bubble_counts) #endif end subroutine s_restart_bubbles + !> Contains the bubble dynamics subroutines. !! @param q_prim_vf Primitive variables !! @param stage Current stage in the time-stepper algorithm @@ -571,7 +566,7 @@ contains if (adap_dt) then call s_advance_step(myRho, myPinf, myR, myV, myR0, myPb, myPbdot, dmalf, dmntait, dmBtait, dm_bub_adv_src, & - & dm_divu, k, myMass_v, myMass_n, myBeta_c, myBeta_t, myCson, adap_dt_stop) + & dm_divu, k, myMass_v, myMass_n, myBeta_c, myBeta_t, myCson, adap_dt_stop) ! Update bubble state intfc_rad(k, 1) = myR @@ -582,7 +577,7 @@ contains ! Radial acceleration from bubble models intfc_dveldt(k, stage) = f_rddot(myRho, myPinf, myR, myV, myR0, myPb, myPbdot, dmalf, dmntait, dmBtait, & - & dm_bub_adv_src, dm_divu, myCson) + & dm_bub_adv_src, dm_divu, myCson) intfc_draddt(k, stage) = myV gas_dmvdt(k, stage) = myMvdot gas_dpdt(k, stage) = myPbdot @@ -606,6 +601,7 @@ contains call nvtxEndRange end subroutine s_compute_bubble_EL_dynamics + !> The purpose of this subroutine is to obtain the bubble source terms based on Maeda and Colonius (2018) and add them to the !! RHS scalar field. !! @param q_cons_vf Conservative variables @@ -629,7 +625,7 @@ contains do l = 1, E_idx if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then rhs_vf(l)%sf(i, j, k) = rhs_vf(l)%sf(i, j, k) + q_cons_vf(l)%sf(i, j, k)*(q_beta(2)%sf(i, j, & - & k) + q_beta(5)%sf(i, j, k)) + & k) + q_beta(5)%sf(i, j, k)) end if end do end do @@ -644,7 +640,7 @@ contains do l = 1, E_idx if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then rhs_vf(l)%sf(i, j, k) = rhs_vf(l)%sf(i, j, k) + q_cons_vf(l)%sf(i, j, k)/q_beta(1)%sf(i, j, & - & k)*q_beta(2)%sf(i, j, k) + & k)*q_beta(2)%sf(i, j, k) end if end do end do @@ -663,7 +659,7 @@ contains do i = 0, m if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then rhs_vf(contxe + l)%sf(i, j, k) = rhs_vf(contxe + l)%sf(i, j, k) - (1._wp - q_beta(1)%sf(i, j, & - & k))/q_beta(1)%sf(i, j, k)*q_beta(3)%sf(i, j, k) + & k))/q_beta(1)%sf(i, j, k)*q_beta(3)%sf(i, j, k) end if end do end do @@ -690,7 +686,7 @@ contains do i = 0, m if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then rhs_vf(E_idx)%sf(i, j, k) = rhs_vf(E_idx)%sf(i, j, k) - q_beta(4)%sf(i, j, & - & k)*(1._wp - q_beta(1)%sf(i, j, k))/q_beta(1)%sf(i, j, k) + & k)*(1._wp - q_beta(1)%sf(i, j, k))/q_beta(1)%sf(i, j, k) end if end do end do @@ -699,6 +695,7 @@ contains end do end if end subroutine s_compute_bubbles_EL_source + !> This procedure computes the speed of sound from a given driving pressure !! @param q_prim_vf Primitive variables !! @param pinf Driving pressure @@ -731,6 +728,7 @@ contains H = (E + pinf)/rhol cson = sqrt((H - 0.5_wp*dot_product(vel, vel))/gamma) end subroutine s_compute_cson_from_pinf + !> The purpose of this subroutine is to smear the effect of the bubbles in the Eulerian framework subroutine s_smear_voidfraction() integer :: i, j, k, l @@ -766,6 +764,7 @@ contains call nvtxEndRange end subroutine s_smear_voidfraction + !> The purpose of this procedure is obtain the bubble driving pressure p_inf !! @param bub_id Particle identifier !! @param q_prim_vf Primitive variables @@ -942,7 +941,7 @@ contains charpres = charpres + q_prim_vf(E_idx)%sf(cellaux(1), cellaux(2), cellaux(3))*vol charvol2 = charvol2 + vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) charpres2 = charpres2 + q_prim_vf(E_idx)%sf(cellaux(1), cellaux(2), & - & cellaux(3))*vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) + & cellaux(3))*vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) end if end do end do @@ -975,6 +974,7 @@ contains end if end if end subroutine s_get_pinf + !> This subroutine updates the Lagrange variables using the tvd RK time steppers. The time derivative of the bubble variables !! must be stored at every stage to avoid precision errors. !! @param stage Current tvd RK stage @@ -1068,13 +1068,13 @@ contains do k = 1, nBubs ! u{n+1} = u{n} + (2/3) * dt * [(1/4)* RHS{n} + (1/4)* RHS{1} + RHS{2}] intfc_rad(k, 1) = intfc_rad(k, 1) + (2._wp/3._wp)*dt*(intfc_draddt(k, 1)/4._wp + intfc_draddt(k, & - & 2)/4._wp + intfc_draddt(k, 3)) + & 2)/4._wp + intfc_draddt(k, 3)) intfc_vel(k, 1) = intfc_vel(k, 1) + (2._wp/3._wp)*dt*(intfc_dveldt(k, 1)/4._wp + intfc_dveldt(k, & - & 2)/4._wp + intfc_dveldt(k, 3)) + & 2)/4._wp + intfc_dveldt(k, 3)) mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dposdt(k, 1:3, 1)/4._wp + mtn_dposdt(k, 1:3, & - & 2)/4._wp + mtn_dposdt(k, 1:3, 3)) + & 2)/4._wp + mtn_dposdt(k, 1:3, 3)) mtn_vel(k, 1:3, 1) = mtn_vel(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dveldt(k, 1:3, 1)/4._wp + mtn_dveldt(k, 1:3, & - & 2)/4._wp + mtn_dveldt(k, 1:3, 3)) + & 2)/4._wp + mtn_dveldt(k, 1:3, 3)) gas_p(k, 1) = gas_p(k, 1) + (2._wp/3._wp)*dt*(gas_dpdt(k, 1)/4._wp + gas_dpdt(k, 2)/4._wp + gas_dpdt(k, 3)) gas_mv(k, 1) = gas_mv(k, 1) + (2._wp/3._wp)*dt*(gas_dmvdt(k, 1)/4._wp + gas_dmvdt(k, 2)/4._wp + gas_dmvdt(k, 3)) end do @@ -1091,6 +1091,7 @@ contains end if end if end subroutine s_update_lagrange_tdv_rk + !> This subroutine returns the computational coordinate of the cell for the given position. !! @param pos Input coordinates !! @param cell Computational coordinate of the cell @@ -1142,6 +1143,7 @@ contains if (scoord(i) < 0._wp) cell(i) = cell(i) - 1 end do end subroutine s_locate_cell + !> This subroutine transfer data into the temporal variables. impure subroutine s_transfer_data_to_tmp() integer :: k @@ -1159,6 +1161,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_transfer_data_to_tmp + !> The purpose of this procedure is to determine if the global coordinates of the bubbles are present in the current MPI !! processor (including ghost cells). !! @param pos_part Spatial coordinates of the bubble @@ -1171,21 +1174,19 @@ contains ! Defining a virtual z-axis that has the same dimensions as y-axis ! defined in the input file particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & - & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) & - & .and. (pos_part(3) < lag_params%charwidth/2._wp) .and. (pos_part(3) >= & - & -lag_params%charwidth/2._wp)) + & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) .and. (pos_part(3) & + & < lag_params%charwidth/2._wp) .and. (pos_part(3) >= -lag_params%charwidth/2._wp)) else ! cyl_coord particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & - & .and. (abs(pos_part(2)) < y_cb(n + buff_size)) .and. (abs(pos_part(2)) >= max(y_cb(-buff_size & - & - 1), 0._wp))) + & .and. (abs(pos_part(2)) < y_cb(n + buff_size)) .and. (abs(pos_part(2)) >= max(y_cb(-buff_size - 1), 0._wp))) end if ! 3D if (p > 0) then particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & - & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) & - & .and. (pos_part(3) < z_cb(p + buff_size)) .and. (pos_part(3) >= z_cb(-buff_size - 1))) + & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) .and. (pos_part(3) & + & < z_cb(p + buff_size)) .and. (pos_part(3) >= z_cb(-buff_size - 1))) end if ! For symmetric and wall boundary condition @@ -1210,6 +1211,7 @@ contains end if end if end function particle_in_domain + !> The purpose of this procedure is to determine if the lagrangian bubble is located in the physical domain. The ghost cells are !! not part of the physical domain. !! @param pos_part Spatial coordinates of the bubble @@ -1218,13 +1220,14 @@ contains real(wp), dimension(3), intent(in) :: pos_part particle_in_domain_physical = ((pos_part(1) < x_cb(m)) .and. (pos_part(1) >= x_cb(-1)) .and. (pos_part(2) < y_cb(n)) & - & .and. (pos_part(2) >= y_cb(-1))) + & .and. (pos_part(2) >= y_cb(-1))) if (p > 0) then particle_in_domain_physical = (particle_in_domain_physical .and. (pos_part(3) < z_cb(p)) .and. (pos_part(3) & - & >= z_cb(-1))) + & >= z_cb(-1))) end if end function particle_in_domain_physical + !> The purpose of this procedure is to calculate the gradient of a scalar field along the x, y and z directions following a !! second-order central difference considering uneven widths !! @param q Input scalar field @@ -1242,7 +1245,7 @@ contains do j = 0, n do i = 0, m dq(i, j, k) = q(i, j, k)*(dx(i + 1) - dx(i - 1)) + q(i + 1, j, k)*(dx(i) + dx(i - 1)) - q(i - 1, j, & - & k)*(dx(i) + dx(i + 1)) + & k)*(dx(i) + dx(i + 1)) dq(i, j, k) = dq(i, j, k)/((dx(i) + dx(i - 1))*(dx(i) + dx(i + 1))) end do end do @@ -1255,7 +1258,7 @@ contains do j = 0, n do i = 0, m dq(i, j, k) = q(i, j, k)*(dy(j + 1) - dy(j - 1)) + q(i, j + 1, k)*(dy(j) + dy(j - 1)) - q(i, j - 1, & - & k)*(dy(j) + dy(j + 1)) + & k)*(dy(j) + dy(j + 1)) dq(i, j, k) = dq(i, j, k)/((dy(j) + dy(j - 1))*(dy(j) + dy(j + 1))) end do end do @@ -1268,7 +1271,7 @@ contains do j = 0, n do i = 0, m dq(i, j, k) = q(i, j, k)*(dz(k + 1) - dz(k - 1)) + q(i, j, k + 1)*(dz(k) + dz(k - 1)) - q(i, j, & - & k - 1)*(dz(k) + dz(k + 1)) + & k - 1)*(dz(k) + dz(k + 1)) dq(i, j, k) = dq(i, j, k)/((dz(k) + dz(k - 1))*(dz(k) + dz(k + 1))) end do end do @@ -1276,6 +1279,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_gradient_dir + !> Subroutine that writes on each time step the changes of the lagrangian bubbles. !! @param qtime Current time impure subroutine s_write_lag_particles(qtime) @@ -1298,7 +1302,7 @@ contains if (.not. file_exist) then open (11, FILE=trim(file_loc), form='formatted', position='rewind') write (11, FMT) 'currentTime', 'particleID', 'x', 'y', 'z', 'coreVaporMass', 'coreVaporConcentration', 'radius', & - & 'interfaceVelocity', 'corePressure' + & 'interfaceVelocity', 'corePressure' else open (11, FILE=trim(file_loc), form='formatted', position='append') end if @@ -1312,11 +1316,12 @@ contains ! Cycle through list do k = 1, nBubs write (11, FMT) qtime, lag_id(k, 1), mtn_pos(k, 1, 1), mtn_pos(k, 2, 1), mtn_pos(k, 3, 1), gas_mv(k, 1), gas_mv(k, & - & 1)/(gas_mv(k, 1) + gas_mg(k)), intfc_rad(k, 1), intfc_vel(k, 1), gas_p(k, 1) + & 1)/(gas_mv(k, 1) + gas_mg(k)), intfc_rad(k, 1), intfc_vel(k, 1), gas_p(k, 1) end do close (11) end subroutine s_write_lag_particles + !> Subroutine that writes some useful statistics related to the volume fraction of the particles (void fraction) in the !! computatioational domain on each time step. !! @param qtime Current time @@ -1349,7 +1354,7 @@ contains lag_void_avg = 0._wp lag_vol = 0._wp $:GPU_PARALLEL_LOOP(private='[volcell]', collapse=3, reduction='[[lag_vol, lag_void_avg], [lag_void_max]]', & - & reductionOp='[+, MAX]', copy='[lag_vol, lag_void_avg, lag_void_max]') + & reductionOp='[+, MAX]', copy='[lag_vol, lag_void_avg, lag_void_max]') do k = 0, p do j = 0, n do i = 0, m @@ -1384,6 +1389,7 @@ contains close (12) end if end subroutine s_write_void_evol + !> Subroutine that writes the restarting files for the particles in the lagrangian solver. !! @param t_step Current time step impure subroutine s_write_restart_lag_bubbles(t_step) @@ -1494,7 +1500,7 @@ contains ! Skip header (written by rank 0) disp = int(sizeof(tot_part) + 2*sizeof(mytime) + sizeof(num_procs) + num_procs*sizeof(proc_bubble_counts(1)), & - & MPI_OFFSET_KIND) + & MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA_lag_bubbles, lag_io_vars*bub_id, mpi_p, status, ierr) @@ -1510,7 +1516,7 @@ contains ! Skip header (written by rank 0) disp = int(sizeof(tot_part) + 2*sizeof(mytime) + sizeof(num_procs) + num_procs*sizeof(proc_bubble_counts(1)), & - & MPI_OFFSET_KIND) + & MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -1521,6 +1527,7 @@ contains deallocate (proc_bubble_counts) #endif end subroutine s_write_restart_lag_bubbles + !> This procedure calculates the maximum and minimum radius of each bubble. subroutine s_calculate_lag_bubble_stats() integer :: k @@ -1534,6 +1541,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_calculate_lag_bubble_stats + !> Subroutine that writes the maximum and minimum radius of each bubble. impure subroutine s_write_lag_bubble_stats() integer :: k @@ -1562,11 +1570,12 @@ contains do k = 1, nBubs write (13, FMT) proc_rank, lag_id(k, 1), mtn_pos(k, 1, 1), mtn_pos(k, 2, 1), mtn_pos(k, 3, 1), Rmax_stats(k), & - & Rmin_stats(k) + & Rmin_stats(k) end do close (13) end subroutine s_write_lag_bubble_stats + !> The purpose of this subroutine is to remove one specific particle if dt is too small. !! @param bub_id Particle id impure subroutine s_remove_lag_bubble(bub_id) @@ -1600,6 +1609,7 @@ contains nBubs = nBubs - 1 $:GPU_UPDATE(device='[nBubs]') end subroutine s_remove_lag_bubble + !> The purpose of this subroutine is to deallocate variables impure subroutine s_finalize_lagrangian_solver() integer :: i diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index 0bb8885235..33cb424583 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -32,6 +32,7 @@ contains call s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) end select smoothfunc end subroutine s_smoothfunction + !> The purpose of this procedure contains the algorithm to use the delta kernel function to map the effect of the bubbles. The !! effect of the bubbles only affects the cell where the bubble is located. subroutine s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) @@ -82,6 +83,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_deltafunc + !> The purpose of this procedure contains the algorithm to use the gaussian kernel function to map the effect of the bubbles. !! The effect of the bubbles affects the 3X3x3 cells that surround the bubble. subroutine s_gaussian(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) @@ -157,13 +159,13 @@ contains addFun1 = func*strength_vol $:GPU_ATOMIC(atomic='update') updatedvar(1)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(1)%sf(cellaux(1), cellaux(2), & - & cellaux(3)) + real(addFun1, kind=stp) + & cellaux(3)) + real(addFun1, kind=stp) ! Update time derivative of void fraction addFun2 = func*strength_vel $:GPU_ATOMIC(atomic='update') updatedvar(2)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(2)%sf(cellaux(1), cellaux(2), & - & cellaux(3)) + real(addFun2, kind=stp) + & cellaux(3)) + real(addFun2, kind=stp) ! Product of two smeared functions ! Update void fraction * time derivative of void fraction @@ -171,7 +173,7 @@ contains addFun3 = func2*strength_vol*strength_vel $:GPU_ATOMIC(atomic='update') updatedvar(5)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(5)%sf(cellaux(1), cellaux(2), & - & cellaux(3)) + real(addFun3, kind=stp) + & cellaux(3)) + real(addFun3, kind=stp) end if end do end do @@ -179,6 +181,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_gaussian + !> The purpose of this subroutine is to apply the gaussian kernel function for each bubble (Maeda and Colonius, 2018)). subroutine s_applygaussian(center, cellaux, nodecoord, stddsv, strength_idx, func) $:GPU_ROUTINE(function_name='s_applygaussian',parallelism='[seq]', cray_inline=True) @@ -218,7 +221,7 @@ contains distance = sqrt((center(1) - nodecoord(1))**2._wp + L2) ! nodecoord(2)*dtheta is the azimuthal width of the cell func = func + dtheta/2._wp/pi*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv) & - & **(3._wp*(strength_idx + 1._wp)) + & **(3._wp*(strength_idx + 1._wp)) end do else @@ -236,11 +239,12 @@ contains Lz2 = (center(3) - (dzp*(0.5_wp + Nr_count) - lag_params%charwidth/2._wp))**2._wp distance = sqrt((center(1) - nodecoord(1))**2._wp + (center(2) - nodecoord(2))**2._wp + Lz2) func = func + dzp/lag_params%charwidth*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv) & - & **(3._wp*(strength_idx + 1._wp)) + & **(3._wp*(strength_idx + 1._wp)) end do end if end if end subroutine s_applygaussian + !> The purpose of this subroutine is to check if the current cell is outside the computational domain or not (including ghost !! cells). !! @param cellaux Tested cell to smear the bubble effect in. @@ -273,6 +277,7 @@ contains end if end if end subroutine s_check_celloutside + !> This subroutine relocates the current cell, if it intersects a symmetric boundary. !! @param cell Cell of the current bubble !! @param cellaux Cell to map the bubble effect in. @@ -308,6 +313,7 @@ contains end if end if end subroutine s_shift_cell_symmetric_bc + !> Calculates the standard deviation of the bubble being smeared in the Eulerian framework. !! @param cell Cell where the bubble is located !! @param volpart Volume of the bubble @@ -344,6 +350,7 @@ contains stddsv = 0._wp end if end subroutine s_compute_stddsv + !> The purpose of this procedure is to calculate the characteristic cell volume !! @param cellx x-direction cell index !! @param celly y-direction cell index @@ -365,6 +372,7 @@ contains end if end if end subroutine s_get_char_vol + !> This subroutine transforms the computational coordinates of the bubble from real type into integer. !! @param s_cell Computational coordinates of the bubble, real type !! @param get_cell Computational coordinates of the bubble, integer type diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index d2cd85cd8c..70bf11b543 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -8,13 +8,9 @@ module m_cbc use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion !< State variables type conversion procedures - use m_compute_cbc - use m_thermochem, only: get_mixture_energy_mass, get_mixture_specific_heat_cv_mass, get_mixture_specific_heat_cp_mass, & & gas_constant, get_mixture_molecular_weight, get_species_enthalpies_rt, molecular_weights, get_species_specific_heats_r, & & get_mole_fractions, get_species_specific_heats_r @@ -305,8 +301,7 @@ contains end if end if - $:GPU_UPDATE(device='[fd_coef_x,fd_coef_y,fd_coef_z, & - & pi_coef_x, pi_coef_y, pi_coef_z]') + $:GPU_UPDATE(device='[fd_coef_x, fd_coef_y, fd_coef_z, pi_coef_x, pi_coef_y, pi_coef_z]') ! Associating the procedural pointer to the appropriate subroutine ! that will be utilized in the conversion to the mixture variables @@ -361,6 +356,7 @@ contains #:endfor $:GPU_UPDATE(device='[vel_in, vel_out, pres_in, pres_out, Del_in, Del_out, alpha_rho_in, alpha_in]') end subroutine s_initialize_cbc_module + !> Compute CBC coefficients !! @param cbc_dir_in CBC coordinate direction !! @param cbc_loc_in CBC coordinate location @@ -410,34 +406,32 @@ contains fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp fd_coef_${XYZ}$ (0, & - & cbc_loc_in) = -50._wp/(25._wp*ds(0) + 2._wp*ds(1) - 1.e1_wp*ds(2) + 1.e1_wp*ds(3) & - & - 3._wp*ds(4)) + & cbc_loc_in) = -50._wp/(25._wp*ds(0) + 2._wp*ds(1) - 1.e1_wp*ds(2) + 1.e1_wp*ds(3) - 3._wp*ds(4)) fd_coef_${XYZ}$ (1, cbc_loc_in) = -48._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (2, cbc_loc_in) = 36._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (3, cbc_loc_in) = -16._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (4, cbc_loc_in) = 3._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp pi_coef_${XYZ}$ (0, 0, & - & cbc_loc_in) = ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)))/((s_cb(1) & - & - s_cb(4))*(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) + & cbc_loc_in) = ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)))/((s_cb(1) - s_cb(4)) & + & *(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) pi_coef_${XYZ}$ (0, 1, & - & cbc_loc_in) = ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(1) & - & - s_cb(3)) - (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + (s_cb(4) - s_cb(1)))))/((s_cb(0) & - & - s_cb(3))*(s_cb(1) - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) + & cbc_loc_in) = ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(1) - s_cb(3)) & + & - (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + (s_cb(4) - s_cb(1)))))/((s_cb(0) - s_cb(3))*(s_cb(1) & + & - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) pi_coef_${XYZ}$ (0, 2, & - & cbc_loc_in) = (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)) + ((s_cb(0) & - & - s_cb(2)) + (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/((s_cb(2) - s_cb(0))*(s_cb(0) & - & - s_cb(3))*(s_cb(0) - s_cb(4))) + & cbc_loc_in) = (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)) + ((s_cb(0) - s_cb(2)) & + & + (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/((s_cb(2) - s_cb(0))*(s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) pi_coef_${XYZ}$ (1, 0, & - & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))*(s_cb(2) - s_cb(3)))/((s_cb(2) & - & - s_cb(4))*(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) + & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))*(s_cb(2) - s_cb(3)))/((s_cb(2) - s_cb(4)) & + & *(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) pi_coef_${XYZ}$ (1, 1, & - & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(2) & - & - s_cb(3)) + (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + (s_cb(2) - s_cb(4)))))/((s_cb(0) & - & - s_cb(3))*(s_cb(1) - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) + & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(2) - s_cb(3)) & + & + (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + (s_cb(2) - s_cb(4)))))/((s_cb(0) - s_cb(3))*(s_cb(1) & + & - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) pi_coef_${XYZ}$ (1, 2, & - & cbc_loc_in) = ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))*(s_cb(2) - s_cb(4)))/((s_cb(0) & - & - s_cb(2))*(s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) + & cbc_loc_in) = ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))*(s_cb(2) - s_cb(4)))/((s_cb(0) - s_cb(2)) & + & *(s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) end if end if #:endfor @@ -446,6 +440,7 @@ contains ! Nullifying CBC coefficients end subroutine s_compute_cbc_coefficients + !> @brief Associates finite-difference and polynomial-interpolation CBC coefficients with targets based on coordinate direction !! and boundary location. The goal of the procedure is to associate the FD and PI coefficients, or CBC coefficients, with the !! appropriate targets, based on the coordinate direction and location of the CBC. @@ -501,6 +496,7 @@ contains $:GPU_UPDATE(device='[ds]') end subroutine s_associate_cbc_coefficients_pointers + !> The following is the implementation of the CBC based on the work of Thompson (1987, 1990) on hyperbolic systems. The CBC is !! indirectly applied in the computation of the right-hand-side (RHS) near the relevant domain boundary through the modification !! of the fluxes. @@ -547,13 +543,13 @@ contains #:endif real(wp), dimension(2) :: Re_cbc real(wp), dimension(3) :: lambda - real(wp) :: rho !< Cell averaged density - real(wp) :: pres !< Cell averaged pressure - real(wp) :: E !< Cell averaged energy - real(wp) :: H !< Cell averaged enthalpy - real(wp) :: gamma !< Cell averaged specific heat ratio - real(wp) :: pi_inf !< Cell averaged liquid stiffness - real(wp) :: qv !< Cell averaged fluid reference energy + real(wp) :: rho !< Cell averaged density + real(wp) :: pres !< Cell averaged pressure + real(wp) :: E !< Cell averaged energy + real(wp) :: H !< Cell averaged enthalpy + real(wp) :: gamma !< Cell averaged specific heat ratio + real(wp) :: pi_inf !< Cell averaged liquid stiffness + real(wp) :: qv !< Cell averaged fluid reference energy real(wp) :: c real(wp) :: Ma real(wp) :: T, sum_Enthalpies @@ -579,14 +575,14 @@ contains ! PI2 of flux_rs_vf and flux_src_rs_vf at j = 1/2 if (weno_order == 3 .or. dummy) then call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, F_rs${XYZ}$_vf, F_src_rs${XYZ}$_vf, is1, is2, & - & is3, idwbuff(2)%beg, idwbuff(3)%beg) + & is3, idwbuff(2)%beg, idwbuff(3)%beg) $:GPU_PARALLEL_LOOP(private='[i, r, k]', collapse=3) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end flux_rs${XYZ}$_vf_l(0, k, r, i) = F_rs${XYZ}$_vf(0, k, r, i) + pi_coef_${XYZ}$ (0, 0, & - & cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, i) - F_rs${XYZ}$_vf(0, k, r, i)) + & cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, i) - F_rs${XYZ}$_vf(0, k, r, i)) end do end do end do @@ -597,7 +593,7 @@ contains do r = is3%beg, is3%end do k = is2%beg, is2%end flux_src_rs${XYZ}$_vf_l(0, k, r, i) = F_src_rs${XYZ}$_vf(0, k, r, i) + (F_src_rs${XYZ}$_vf(1, k, & - & r, i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (0, 0, cbc_loc) + & r, i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (0, 0, cbc_loc) end do end do end do @@ -607,7 +603,7 @@ contains ! PI4 of flux_rs_vf and flux_src_rs_vf at j = 1/2, 3/2 if (weno_order == 5 .or. dummy) then call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, F_rs${XYZ}$_vf, F_src_rs${XYZ}$_vf, is1, is2, & - & is3, idwbuff(2)%beg, idwbuff(3)%beg) + & is3, idwbuff(2)%beg, idwbuff(3)%beg) $:GPU_PARALLEL_LOOP(private='[i, j, r, k]', collapse=4) do i = 1, flux_cbc_index @@ -615,10 +611,10 @@ contains do r = is3%beg, is3%end do k = is2%beg, is2%end flux_rs${XYZ}$_vf_l(j, k, r, i) = F_rs${XYZ}$_vf(j, k, r, i) + pi_coef_${XYZ}$ (j, 0, & - & cbc_loc)*(F_rs${XYZ}$_vf(3, k, r, i) - F_rs${XYZ}$_vf(2, k, r, & - & i)) + pi_coef_${XYZ}$ (j, 1, cbc_loc)*(F_rs${XYZ}$_vf(2, k, r, & - & i) - F_rs${XYZ}$_vf(1, k, r, i)) + pi_coef_${XYZ}$ (j, 2, & - & cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, i) - F_rs${XYZ}$_vf(0, k, r, i)) + & cbc_loc)*(F_rs${XYZ}$_vf(3, k, r, i) - F_rs${XYZ}$_vf(2, k, r, & + & i)) + pi_coef_${XYZ}$ (j, 1, cbc_loc)*(F_rs${XYZ}$_vf(2, k, r, i) - F_rs${XYZ}$_vf(1, & + & k, r, i)) + pi_coef_${XYZ}$ (j, 2, cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, & + & i) - F_rs${XYZ}$_vf(0, k, r, i)) end do end do end do @@ -631,11 +627,10 @@ contains do r = is3%beg, is3%end do k = is2%beg, is2%end flux_src_rs${XYZ}$_vf_l(j, k, r, i) = F_src_rs${XYZ}$_vf(j, k, r, i) + (F_src_rs${XYZ}$_vf(3, & - & k, r, i) - F_src_rs${XYZ}$_vf(2, k, r, i))*pi_coef_${XYZ}$ (j, 0, & - & cbc_loc) + (F_src_rs${XYZ}$_vf(2, k, r, i) - F_src_rs${XYZ}$_vf(1, & - & k, r, i))*pi_coef_${XYZ}$ (j, 1, cbc_loc) + (F_src_rs${XYZ}$_vf(1, & - & k, r, i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (j, 2, & - & cbc_loc) + & k, r, i) - F_src_rs${XYZ}$_vf(2, k, r, i))*pi_coef_${XYZ}$ (j, 0, & + & cbc_loc) + (F_src_rs${XYZ}$_vf(2, k, r, i) - F_src_rs${XYZ}$_vf(1, k, r, & + & i))*pi_coef_${XYZ}$ (j, 1, cbc_loc) + (F_src_rs${XYZ}$_vf(1, k, r, & + & i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (j, 2, cbc_loc) end do end do end do @@ -759,7 +754,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_species dYs_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, chemxb - 1 + i)*fd_coef_${XYZ}$ (j, & - & cbc_loc) + dYs_ds(i) + & cbc_loc) + dYs_ds(i) end do end if end do @@ -775,18 +770,18 @@ contains & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SLIP_WALL)) then call s_compute_slip_wall_L(lambda, L, rho, c, dpres_ds, dvel_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_BUFFER) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_BUFFER)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_BUFFER)) then call s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds, dYs_ds) + & dvel_ds, dadv_ds, dYs_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_INFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_INFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_INFLOW)) then call s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, dpres_ds, dvel_ds) ! Add GRCBC for Subsonic Inflow if (bc_${XYZ}$%grcbc_in) then $:GPU_LOOP(parallelism='[seq]') do i = 2, momxb L(i) = c**3._wp*Ma*(alpha_rho(i - 1) - alpha_rho_in(i - 1, & - & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) - c*Ma*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) + & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) - c*Ma*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) end do if (n > 0) then L(momxb + 1) = c*Ma*(vel(dir_idx(2)) - vel_in(${CBC_DIR}$, dir_idx(2)))/Del_in(${CBC_DIR}$) @@ -797,15 +792,16 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = E_idx, advxe - 1 L(i) = c*Ma*(adv_local(i + 1 - E_idx) - alpha_in(i + 1 - E_idx, & - & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) + & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) end do L(advxe) = rho*c**2._wp*(1._wp + Ma)*(vel(dir_idx(1)) + vel_in(${CBC_DIR}$, dir_idx(1))*sign(1, & - & cbc_loc))/Del_in(${CBC_DIR}$) + c*(1._wp + Ma)*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) + & cbc_loc))/Del_in(${CBC_DIR}$) + c*(1._wp + Ma)*(pres - pres_in(${CBC_DIR}$)) & + & /Del_in(${CBC_DIR}$) end if else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_OUTFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_OUTFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_OUTFLOW)) then call s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds, dYs_ds) + & dvel_ds, dadv_ds, dYs_ds) ! Add GRCBC for Subsonic Outflow (Pressure) if (bc_${XYZ}$%grcbc_out) then L(advxe) = c*(1._wp - Ma)*(pres - pres_out(${CBC_DIR}$))/Del_out(${CBC_DIR}$) @@ -813,24 +809,24 @@ contains ! Add GRCBC for Subsonic Outflow (Normal Velocity) if (bc_${XYZ}$%grcbc_vel_out) then L(advxe) = L(advxe) + rho*c**2._wp*(1._wp - Ma)*(vel(dir_idx(1)) + vel_out(${CBC_DIR}$, & - & dir_idx(1))*sign(1, cbc_loc))/Del_out(${CBC_DIR}$) + & dir_idx(1))*sign(1, cbc_loc))/Del_out(${CBC_DIR}$) end if end if else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_FF_SUB_OUTFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_FF_SUB_OUTFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_FF_SUB_OUTFLOW)) then call s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, & - & dadv_ds) + & dadv_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_CP_SUB_OUTFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_CP_SUB_OUTFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_CP_SUB_OUTFLOW)) then call s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds) + & dvel_ds, dadv_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_INFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_INFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_INFLOW)) then call s_compute_supersonic_inflow_L(L) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_OUTFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_OUTFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_OUTFLOW)) then call s_compute_supersonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, & - & dYs_ds) + & dYs_ds) end if ! Be careful about the cylindrical coordinate! @@ -848,7 +844,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims dvel_dt(dir_idx(i)) = dir_flg(dir_idx(i))*(L(1) - L(advxe))/(2._wp*rho*c) + (dir_flg(dir_idx(i)) & - & - 1._wp)*L(momxb + i - 1) + & - 1._wp)*L(momxb + i - 1) end do vel_dv_dt_sum = 0._wp @@ -904,7 +900,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, momxe flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, & - & i) + ds(0)*(vel(i - contxe)*drho_dt + rho*dvel_dt(i - contxe)) + & i) + ds(0)*(vel(i - contxe)*drho_dt + rho*dvel_dt(i - contxe)) end do if (chemistry) then @@ -917,24 +913,23 @@ contains #:if USING_AMD h_k(i) = h_k(i)*gas_constant/molecular_weights_nonparameter(i)*T sum_Enthalpies = sum_Enthalpies + (rho*h_k(i) - pres*Mw/molecular_weights_nonparameter(i) & - & *Cp/R_gas)*dYs_dt(i) + & *Cp/R_gas)*dYs_dt(i) #:else h_k(i) = h_k(i)*gas_constant/molecular_weights(i)*T sum_Enthalpies = sum_Enthalpies + (rho*h_k(i) - pres*Mw/molecular_weights(i)*Cp/R_gas)*dYs_dt(i) #:endif end do flux_rs${XYZ}$_vf_l(-1, k, r, E_idx) = flux_rs${XYZ}$_vf_l(0, k, r, & - & E_idx) + ds(0)*((E/rho + pres/rho)*drho_dt + rho*vel_dv_dt_sum + Cp*T*L(2)/(c*c) & - & + sum_Enthalpies) + & E_idx) + ds(0)*((E/rho + pres/rho)*drho_dt + rho*vel_dv_dt_sum + Cp*T*L(2)/(c*c) + sum_Enthalpies) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_species flux_rs${XYZ}$_vf_l(-1, k, r, i - 1 + chemxb) = flux_rs${XYZ}$_vf_l(0, k, r, & - & chemxb + i - 1) + ds(0)*(drho_dt*Ys(i) + rho*dYs_dt(i)) + & chemxb + i - 1) + ds(0)*(drho_dt*Ys(i) + rho*dYs_dt(i)) end do else flux_rs${XYZ}$_vf_l(-1, k, r, E_idx) = flux_rs${XYZ}$_vf_l(0, k, r, & - & E_idx) + ds(0)*(pres*dgamma_dt + gamma*dpres_dt + dpi_inf_dt + dqv_dt & - & + rho*vel_dv_dt_sum + 5.e-1_wp*drho_dt*vel_K_sum) + & E_idx) + ds(0)*(pres*dgamma_dt + gamma*dpres_dt + dpi_inf_dt + dqv_dt + rho*vel_dv_dt_sum & + & + 5.e-1_wp*drho_dt*vel_K_sum) end if if (riemann_solver == 1) then @@ -946,9 +941,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_src_rs${XYZ}$_vf_l(-1, k, r, i) = 1._wp/max(abs(vel(dir_idx(1))), sgm_eps)*sign(1._wp, & - & vel(dir_idx(1)))*(flux_rs${XYZ}$_vf_l(0, k, r, & - & i) + vel(dir_idx(1))*flux_src_rs${XYZ}$_vf_l(0, k, r, & - & i) + ds(0)*dadv_dt(i - E_idx)) + & vel(dir_idx(1)))*(flux_rs${XYZ}$_vf_l(0, k, r, & + & i) + vel(dir_idx(1))*flux_src_rs${XYZ}$_vf_l(0, k, r, i) + ds(0)*dadv_dt(i - E_idx)) end do else @@ -976,6 +970,7 @@ contains ! CBC coordinate direction. call s_finalize_cbc(flux_vf, flux_src_vf) end subroutine s_cbc + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are required for the setup of the selected CBC. !! @param q_prim_vf Cell-average primitive variables @@ -1075,7 +1070,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_rsx_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1103,7 +1098,7 @@ contains do k = is2%beg, is2%end do j = 0, buff_size q_prim_rsy_vf(j, k, r, momxb + 1) = q_prim_vf(momxb + 1)%sf(k, dj*(n - 2*j) + j, r)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1149,7 +1144,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_rsy_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1223,7 +1218,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_rsz_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1235,6 +1230,7 @@ contains ! Association of the procedural pointer to the appropriate procedure ! that will be utilized in the evaluation of L variables for the CBC end subroutine s_initialize_cbc + !> Deallocation and/or the disassociation procedures that are necessary in order to finalize the CBC application !! @param flux_vf Cell-boundary-average fluxes !! @param flux_src_vf Cell-boundary-average flux sources @@ -1287,7 +1283,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r) = flux_src_rsx_vf_l(j, k, r, advxb)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1337,7 +1333,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r) = flux_src_rsy_vf_l(j, k, r, advxb)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1389,7 +1385,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j) = flux_src_rsz_vf_l(j, k, r, advxb)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1398,6 +1394,7 @@ contains end if ! END: Reshaping Outputted Data in z-direction end subroutine s_finalize_cbc + !> @brief Detects whether any domain boundary uses characteristic boundary conditions. elemental subroutine s_any_cbc_boundaries(toggle) logical, intent(inout) :: toggle @@ -1410,6 +1407,7 @@ contains end if #:endfor end subroutine s_any_cbc_boundaries + !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_cbc_module logical :: is_cbc diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 7b3f6fb964..346228df54 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -8,11 +8,8 @@ !> @brief Validates simulation input parameters for consistency and supported configurations module m_checker use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper - use m_helper_basic !< Functions to compare floating point numbers implicit none @@ -38,12 +35,14 @@ contains @:PROHIBIT(ib_state_wrt .and. .not. ib, "ib_state_wrt requires ib to be enabled") end subroutine s_check_inputs + !> Checks constraints on compiler options impure subroutine s_check_inputs_compilers #if !defined(MFC_OpenACC) && !(defined(__PGI) || defined(_CRAYFTN)) @:PROHIBIT(rdma_mpi, "Unsupported value of rdma_mpi for the current compiler") #endif end subroutine s_check_inputs_compilers + !> Checks constraints on WENO scheme parameters impure subroutine s_check_inputs_weno character(len=5) :: numStr !< for int to string conversion @@ -53,6 +52,7 @@ contains @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*weno_order, "For 2D simulation, n must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*weno_order, "For 3D simulation, p must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) end subroutine s_check_inputs_weno + !> @brief Validates that the grid resolution is sufficient for the MUSCL reconstruction order. impure subroutine s_check_inputs_muscl character(len=5) :: numStr !< for int to string conversion @@ -62,12 +62,14 @@ contains @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*muscl_order, "For 2D simulation, n must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*muscl_order, "For 3D simulation, p must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) end subroutine s_check_inputs_muscl + !> Checks constraints on time stepping parameters impure subroutine s_check_inputs_time_stepping if (.not. cfl_dt) then @:PROHIBIT(dt <= 0) end if end subroutine s_check_inputs_time_stepping + impure subroutine s_check_inputs_nvidia_uvm #ifdef __NVCOMPILER_GPU_UNIFIED_MEM @:PROHIBIT(nv_uvm_igr_temps_on_gpu > 3 .or. nv_uvm_igr_temps_on_gpu < 0, "nv_uvm_igr_temps_on_gpu must be in the range [0, 3]") diff --git a/src/simulation/m_compute_cbc.fpp b/src/simulation/m_compute_cbc.fpp index 5931a78d7d..665f8929e0 100644 --- a/src/simulation/m_compute_cbc.fpp +++ b/src/simulation/m_compute_cbc.fpp @@ -27,6 +27,7 @@ contains real(wp) :: L1 L1 = lambda(1)*(dpres_ds - rho*c*dvel_ds(dir_idx(1))) end function f_base_L1 + !> Fill density L variables subroutine s_fill_density_L(L, lambda_factor, lambda2, c, mf, dalpha_rho_ds, dpres_ds) $:GPU_ROUTINE(parallelism='[seq]') @@ -49,6 +50,7 @@ contains L(i) = lambda_factor*lambda2*(c*c*dalpha_rho_ds(i - 1) - mf(i - 1)*dpres_ds) end do end subroutine s_fill_density_L + !> Fill velocity L variables subroutine s_fill_velocity_L(L, lambda_factor, lambda2, dvel_ds) $:GPU_ROUTINE(parallelism='[seq]') @@ -70,6 +72,7 @@ contains L(i) = lambda_factor*lambda2*dvel_ds(dir_idx(i - contxe)) end do end subroutine s_fill_velocity_L + !> Fill advection L variables subroutine s_fill_advection_L(L, lambda_factor, lambda2, dadv_ds) $:GPU_ROUTINE(parallelism='[seq]') @@ -91,6 +94,7 @@ contains L(i) = lambda_factor*lambda2*dadv_ds(i - momxe) end do end subroutine s_fill_advection_L + !> Fill chemistry L variables subroutine s_fill_chemistry_L(L, lambda_factor, lambda2, dYs_ds) $:GPU_ROUTINE(parallelism='[seq]') @@ -114,6 +118,7 @@ contains L(i) = lambda_factor*lambda2*dYs_ds(i - chemxb + 1) end do end subroutine s_fill_chemistry_L + !> Slip wall CBC (Thompson 1990, pg. 451) subroutine s_compute_slip_wall_L(lambda, L, rho, c, dpres_ds, dvel_ds) $:GPU_ROUTINE(function_name='s_compute_slip_wall_L',parallelism='[seq]', cray_inline=True) @@ -136,6 +141,7 @@ contains L(2:advxe - 1) = 0._wp L(advxe) = L(1) end subroutine s_compute_slip_wall_L + !> Nonreflecting subsonic buffer CBC (Thompson 1987, pg. 13) subroutine s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_buffer_L', parallelism='[seq]', cray_inline=True) @@ -173,6 +179,7 @@ contains lambda_factor = (5.e-1_wp - 5.e-1_wp*sign(1._wp, lambda(3))) L(advxe) = lambda_factor*lambda(3)*(dpres_ds + rho*c*dvel_ds(dir_idx(1))) end subroutine s_compute_nonreflecting_subsonic_buffer_L + !> Nonreflecting subsonic inflow CBC (Thompson 1990, pg. 455) subroutine s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, dpres_ds, dvel_ds) $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_inflow_L', parallelism='[seq]', cray_inline=True) @@ -194,6 +201,7 @@ contains L(2:advxe) = 0._wp if (chemistry) L(chemxb:chemxe) = 0._wp end subroutine s_compute_nonreflecting_subsonic_inflow_L + !> Nonreflecting subsonic outflow CBC (Thompson 1990, pg. 454) subroutine s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) @@ -225,6 +233,7 @@ contains call s_fill_chemistry_L(L, 1._wp, lambda(2), dYs_ds) L(advxe) = 0._wp end subroutine s_compute_nonreflecting_subsonic_outflow_L + !> Force-free subsonic outflow CBC (Thompson 1990, pg. 454) subroutine s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) $:GPU_ROUTINE(function_name='s_compute_force_free_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) @@ -253,6 +262,7 @@ contains call s_fill_advection_L(L, 1._wp, lambda(2), dadv_ds) L(advxe) = L(1) + 2._wp*rho*c*lambda(2)*dvel_ds(dir_idx(1)) end subroutine s_compute_force_free_subsonic_outflow_L + !> Constant pressure subsonic outflow CBC (Thompson 1990, pg. 455) subroutine s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) $:GPU_ROUTINE(function_name='s_compute_constant_pressure_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) @@ -281,6 +291,7 @@ contains call s_fill_advection_L(L, 1._wp, lambda(2), dadv_ds) L(advxe) = -L(1) end subroutine s_compute_constant_pressure_subsonic_outflow_L + !> Supersonic inflow CBC (Thompson 1990, pg. 453) subroutine s_compute_supersonic_inflow_L(L) $:GPU_ROUTINE(function_name='s_compute_supersonic_inflow_L', parallelism='[seq]', cray_inline=True) @@ -292,6 +303,7 @@ contains L(1:advxe) = 0._wp if (chemistry) L(chemxb:chemxe) = 0._wp end subroutine s_compute_supersonic_inflow_L + !> Supersonic outflow CBC (Thompson 1990, pg. 453) subroutine s_compute_supersonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) $:GPU_ROUTINE(function_name='s_compute_supersonic_outflow_L', parallelism='[seq]', cray_inline=True) diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index 8484659b2b..279de14b53 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -7,15 +7,10 @@ !> @brief Computes signed-distance level-set fields and surface normals for immersed-boundary patch geometries module m_compute_levelset use m_ib_patches !< The IB patch parameters - use m_model !< Subroutine(s) related to STL files - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers implicit none @@ -72,6 +67,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_apply_levelset + !> @brief Computes the signed distance and outward normal from a ghost point to a circular immersed boundary. subroutine s_circle_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -100,6 +96,7 @@ contains gp%levelset_norm = dist_vec(:)/dist end if end subroutine s_circle_levelset + !> @brief Computes the signed distance and outward normal from a ghost point to a 2D NACA airfoil surface. subroutine s_airfoil_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -108,7 +105,7 @@ contains real(wp) :: dist, global_dist integer :: global_id real(wp), dimension(3) :: dist_vec - real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame real(wp), dimension(1:2) :: center real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation integer :: i, j, k, ib_patch_id !< Loop index variables @@ -177,6 +174,7 @@ contains gp%levelset_norm = matmul(rotation, dist_vec(:))/dist ! convert the normal vector back to global grid coordinates end if end subroutine s_airfoil_levelset + !> @brief Computes the signed distance and outward normal from a ghost point to a 3D extruded airfoil surface including spanwise !! end caps. subroutine s_3d_airfoil_levelset(gp) @@ -190,7 +188,7 @@ contains real(wp), dimension(1:3) :: xyz_local, center, offset, normal !< x, y, z coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation real(wp) :: length_z - integer :: i, j, k, l, ib_patch_id !< Loop index variables + integer :: i, j, k, l, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -274,6 +272,7 @@ contains end if end if end subroutine s_3d_airfoil_levelset + !> Subroutine for computing the levelset values at a ghost point belonging to the rectangle IB subroutine s_rectangle_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -284,11 +283,11 @@ contains real(wp) :: side_dists(4) real(wp) :: length_x, length_y real(wp), dimension(1:3) :: xy_local, dist_vec !< x and y coordinates in local IB frame - real(wp), dimension(2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(2) :: center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - integer :: i, j, k !< Loop index variables - integer :: idx !< Shortest path direction indicator - integer :: ib_patch_id !< patch ID + integer :: i, j, k !< Loop index variables + integer :: idx !< Shortest path direction indicator + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -340,6 +339,7 @@ contains gp%levelset_norm = 0._wp end if end subroutine s_rectangle_levelset + !> @brief Computes the signed distance and outward normal from a ghost point to an elliptical immersed boundary via a quadratic !! projection. subroutine s_ellipse_levelset(gp) @@ -350,11 +350,11 @@ contains real(wp) :: quadratic_coeffs(3) ! A, B, C in the quadratic equation to compute levelset real(wp) :: length_x, length_y real(wp), dimension(1:3) :: xy_local, normal_vector !< x and y coordinates in local IB frame - real(wp), dimension(2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(2) :: center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - integer :: i, j, k !< Loop index variables - integer :: idx !< Shortest path direction indicator - integer :: ib_patch_id !< patch ID + integer :: i, j, k !< Loop index variables + integer :: idx !< Shortest path direction indicator + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -375,20 +375,21 @@ contains normal_vector = xy_local normal_vector(2) = normal_vector(2)*(ellipse_coeffs(1)/ellipse_coeffs(2)) & - & **2._wp ! get the normal direction via the coordinate transformation method + & **2._wp ! get the normal direction via the coordinate transformation method normal_vector = normal_vector/sqrt(dot_product(normal_vector, normal_vector)) ! normalize the vector gp%levelset_norm = matmul(rotation, normal_vector) ! save after rotating the vector to the global frame ! use the normal vector to set up the quadratic equation for the levelset, using A, B, and C in indices 1, 2, and 3 quadratic_coeffs(1) = (normal_vector(1)/ellipse_coeffs(1))**2 + (normal_vector(2)/ellipse_coeffs(2))**2 quadratic_coeffs(2) = 2._wp*((xy_local(1)*normal_vector(1)/(ellipse_coeffs(1)**2)) + (xy_local(2)*normal_vector(2) & - & /(ellipse_coeffs(2)**2))) + & /(ellipse_coeffs(2)**2))) quadratic_coeffs(3) = (xy_local(1)/ellipse_coeffs(1))**2._wp + (xy_local(2)/ellipse_coeffs(2))**2._wp - 1._wp ! compute the levelset with the quadratic equation [ -B + sqrt(B^2 - 4AC) ] / 2A gp%levelset = -0.5_wp*(-quadratic_coeffs(2) + sqrt(quadratic_coeffs(2)**2._wp - 4._wp*quadratic_coeffs(1) & - & *quadratic_coeffs(3)))/quadratic_coeffs(1) + & *quadratic_coeffs(3)))/quadratic_coeffs(1) end subroutine s_ellipse_levelset + !> @brief Computes the signed distance and outward normal from a ghost point to the nearest face of a cuboid immersed boundary. subroutine s_cuboid_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -401,8 +402,8 @@ contains real(wp) :: length_x, length_y, length_z real(wp), dimension(1:3) :: xyz_local, dist_vec !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - integer :: i, j, k !< Loop index variables - integer :: ib_patch_id !< patch ID + integer :: i, j, k !< Loop index variables + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -474,6 +475,7 @@ contains gp%levelset_norm = matmul(rotation, dist_vec) end subroutine s_cuboid_levelset + !> @brief Computes the signed distance and outward normal from a ghost point to a spherical immersed boundary. subroutine s_sphere_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -508,6 +510,7 @@ contains gp%levelset_norm = dist_vec(:)/dist end if end subroutine s_sphere_levelset + !> @brief Computes the signed distance and outward normal from a ghost point to a cylindrical immersed boundary surface and end !! caps. subroutine s_cylinder_levelset(gp) @@ -518,8 +521,8 @@ contains real(wp), dimension(3) :: dist_sides_vec, dist_surface_vec, length real(wp), dimension(2) :: boundary real(wp) :: dist_side, dist_surface, side_pos - integer :: i, j, k !< Loop index variables - integer :: ib_patch_id !< patch ID + integer :: i, j, k !< Loop index variables + integer :: ib_patch_id !< patch ID real(wp), dimension(1:3) :: xyz_local, center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation @@ -580,6 +583,7 @@ contains gp%levelset_norm = matmul(rotation, xyz_local) end if end subroutine s_cylinder_levelset + !> The STL patch is a 2/3D geometry that is imported from an STL file. !! @param gp Ghost point to compute levelset for subroutine s_model_levelset(gp) diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 76a4acea92..86ef8edd1b 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -8,25 +8,15 @@ !> @brief Writes solution data, run-time stability diagnostics (ICFL, VCFL, CCFL, Rc), and probe/center-of-mass files module m_data_output use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_compile_specific - use m_helper - use m_helper_basic !< Functions to compare floating point numbers - use m_sim_helpers - use m_delay_file_access - use m_ibm - use m_boundary_common implicit none @@ -39,17 +29,17 @@ module m_data_output & s_finalize_data_output_module integer :: ib_state_unit = -1 !< I/O unit for IB state binary file - real(wp), allocatable, dimension(:,:,:) :: icfl_sf !< ICFL stability criterion - real(wp), allocatable, dimension(:,:,:) :: vcfl_sf !< VCFL stability criterion - real(wp), allocatable, dimension(:,:,:) :: ccfl_sf !< CCFL stability criterion - real(wp), allocatable, dimension(:,:,:) :: Rc_sf !< Rc stability criterion + real(wp), allocatable, dimension(:,:,:) :: icfl_sf !< ICFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: vcfl_sf !< VCFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: ccfl_sf !< CCFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: Rc_sf !< Rc stability criterion real(wp), public, allocatable, dimension(:,:) :: c_mass $:GPU_DECLARE(create='[icfl_sf, vcfl_sf, ccfl_sf, Rc_sf, c_mass]') real(wp) :: icfl_max_loc, icfl_max_glb !< ICFL stability extrema on local and global grids real(wp) :: vcfl_max_loc, vcfl_max_glb !< VCFL stability extrema on local and global grids real(wp) :: ccfl_max_loc, ccfl_max_glb !< CCFL stability extrema on local and global grids - real(wp) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids + real(wp) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids $:GPU_DECLARE(create='[icfl_max_loc, icfl_max_glb, vcfl_max_loc, vcfl_max_glb]') $:GPU_DECLARE(create='[ccfl_max_loc, ccfl_max_glb, Rc_min_loc, Rc_min_glb]') @@ -58,7 +48,7 @@ module m_data_output real(wp) :: icfl_max !< ICFL criterion maximum real(wp) :: vcfl_max !< VCFL criterion maximum real(wp) :: ccfl_max !< CCFL criterion maximum - real(wp) :: Rc_min !< Rc criterion maximum + real(wp) :: Rc_min !< Rc criterion maximum !> @} type(scalar_field), allocatable, dimension(:) :: q_cons_temp_ds @@ -85,6 +75,7 @@ contains call s_write_parallel_data_files(q_cons_vf, t_step, bc_type, beta) end if end subroutine s_write_data_files + !> The purpose of this subroutine is to open a new or pre- existing run-time information file and append to it the basic header !! information relevant to current simulation. In general, this requires generating a table header for those stability criteria !! which will be written at every time-step. @@ -104,7 +95,7 @@ contains open (3, FILE=trim(file_path), form='formatted', STATUS='replace') write (3, '(A)') 'Description: Stability information at ' // 'each time-step of the simulation. This' - write (3, '(13X,A)') 'data is composed of the inviscid ' // 'Courant-Friedrichs-Lewy (ICFL)' + write (3, '(13X,A)') 'data is composed of the inviscid ' // 'Courant–Friedrichs–Lewy (ICFL)' write (3, '(13X,A)') 'number, the viscous CFL (VCFL) number, ' // 'the capillary CFL (CCFL)' write (3, '(13X,A)') 'number and the cell Reynolds (Rc) ' // 'number. Please note that only' write (3, '(13X,A)') 'those stability conditions pertinent ' // 'to the physics included in' @@ -125,6 +116,7 @@ contains write (3, *) ! new line end subroutine s_open_run_time_information_file + !> This opens a formatted data file where the root processor can write out the CoM information impure subroutine s_open_com_files() character(len=path_len + 3*name_len) :: file_path !< @@ -142,15 +134,16 @@ contains write (i + 120, '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' Total Volume ' else if (p == 0) then write (i + 120, & - & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' & - & // ' Total Volume ' + & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' & + & // ' Total Volume ' else write (i + 120, & - & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' // ' z-loc ' & - & // ' Total Volume ' + & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' // ' z-loc ' & + & // ' Total Volume ' end if end do end subroutine s_open_com_files + !> This opens a formatted data file where the root processor can write out flow probe information impure subroutine s_open_probe_files character(LEN=path_len + 3*name_len) :: file_path !< @@ -184,6 +177,7 @@ contains end do end if end subroutine s_open_probe_files + impure subroutine s_open_ib_state_file character(len=path_len + 2*name_len) :: file_loc integer :: ios @@ -193,6 +187,7 @@ contains open (newunit=ib_state_unit, file=trim(file_loc), form='unformatted', access='stream', status='replace', iostat=ios) if (ios /= 0) call s_mpi_abort('Cannot open IB state output file: ' // trim(file_loc)) end subroutine s_open_ib_state_file + !> The goal of the procedure is to output to the run-time information file the stability criteria extrema in the entire !! computational domain and at the given time-step. Moreover, the subroutine is also in charge of tracking these stability !! criteria extrema over all time-steps. @@ -203,20 +198,20 @@ contains integer, intent(in) :: t_step real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction - real(wp), dimension(3) :: vel !< Cell-avg. velocity + real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction + real(wp), dimension(3) :: vel !< Cell-avg. velocity #:else - real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction - real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity + real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction + real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity #:endif - real(wp) :: vel_sum !< Cell-avg. velocity sum - real(wp) :: pres !< Cell-avg. pressure - real(wp) :: gamma !< Cell-avg. sp. heat ratio - real(wp) :: pi_inf !< Cell-avg. liquid stiffness function - real(wp) :: qv !< Cell-avg. internal energy reference value - real(wp) :: c !< Cell-avg. sound speed - real(wp) :: H !< Cell-avg. enthalpy - real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers + real(wp) :: vel_sum !< Cell-avg. velocity sum + real(wp) :: pres !< Cell-avg. pressure + real(wp) :: gamma !< Cell-avg. sp. heat ratio + real(wp) :: pi_inf !< Cell-avg. liquid stiffness function + real(wp) :: qv !< Cell-avg. internal energy reference value + real(wp) :: c !< Cell-avg. sound speed + real(wp) :: H !< Cell-avg. enthalpy + real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers integer :: j, k, l ! Computing Stability Criteria at Current Time-step @@ -270,7 +265,7 @@ contains ! Determining global stability criteria extrema at current time-step if (num_procs > 1) then call s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & - & Rc_min_glb) + & Rc_min_glb) else icfl_max_glb = icfl_max_loc if (viscous) vcfl_max_glb = vcfl_max_loc @@ -314,6 +309,7 @@ contains call s_mpi_barrier() end subroutine s_write_run_time_information + !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. !! @param q_cons_vf Cell-average conservative variables !! @param q_T_sf Temperature scalar field @@ -489,7 +485,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -501,7 +497,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -549,7 +545,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -563,7 +559,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -640,7 +636,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -656,7 +652,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -696,6 +692,7 @@ contains end if end if end subroutine s_write_serial_data_files + !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. !! @param q_cons_vf Cell-average conservative variables !! @param t_step Current time-step @@ -719,7 +716,7 @@ contains character(LEN=path_len + 2*name_len) :: file_loc logical :: file_exist, dir_check character(len=10) :: t_step_string - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator integer :: alt_sys !< Altered system size for the lagrangian subgrid bubble model ! Down sampling variables @@ -928,6 +925,7 @@ contains end if #endif end subroutine s_write_parallel_data_files + !> @brief Writes immersed boundary marker data to a serial (per-processor) unformatted file. subroutine s_write_serial_ib_data(time_step) integer, intent(in) :: time_step @@ -944,6 +942,7 @@ contains $:GPU_UPDATE(host='[ib_markers%sf]') write (2) ib_markers%sf(0:m, 0:n, 0:p); close (2) end subroutine s_write_serial_ib_data + !> @brief Writes immersed boundary marker data in parallel using MPI I/O. subroutine s_write_parallel_ib_data(time_step) integer, intent(in) :: time_step @@ -980,6 +979,7 @@ contains call MPI_FILE_CLOSE(ifile, ierr) #endif end subroutine s_write_parallel_ib_data + !> @brief Dispatches immersed boundary data output to the serial or parallel writer. subroutine s_write_ib_data_file(time_step) integer, intent(in) :: time_step @@ -990,22 +990,24 @@ contains call s_write_serial_ib_data(time_step) end if end subroutine s_write_ib_data_file + !> @brief Writes IB state records to D/ib_state.dat. Must be called only on rank 0. impure subroutine s_write_ib_state_file() integer :: i do i = 1, num_ibs write (ib_state_unit) mytime, i, patch_ib(i)%force, patch_ib(i)%torque, patch_ib(i)%vel, patch_ib(i)%angular_vel, & - & patch_ib(i)%angles, patch_ib(i)%x_centroid, patch_ib(i)%y_centroid, patch_ib(i)%z_centroid + & patch_ib(i)%angles, patch_ib(i)%x_centroid, patch_ib(i)%y_centroid, patch_ib(i)%z_centroid end do end subroutine s_write_ib_state_file + !> This writes a formatted data file where the root processor can write out the CoM information !! @param t_step Current time-step !! @param c_mass_in Center of mass information impure subroutine s_write_com_files(t_step, c_mass_in) integer, intent(in) :: t_step real(wp), dimension(num_fluids, 5), intent(in) :: c_mass_in - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator real(wp) :: nondim_time !< Non-dimensional time ! Non-dimensional time calculation @@ -1027,11 +1029,12 @@ contains else ! 3D simulation do i = 1, num_fluids ! Loop through fluids write (i + 120, '(6X,6F24.12)') nondim_time, c_mass_in(i, 1), c_mass_in(i, 2), c_mass_in(i, 3), c_mass_in(i, & - & 4), c_mass_in(i, 5) + & 4), c_mass_in(i, 5) end do end if end if end subroutine s_write_com_files + !> This writes a formatted data file for the flow probe information !! @param t_step Current time-step !! @param q_cons_vf Conservative variables @@ -1073,13 +1076,13 @@ contains real(wp) :: dyn_p, T real(wp) :: damage_state integer :: i, j, k, l, s, d !< Generic loop iterator - real(wp) :: nondim_time !< Non-dimensional time - real(wp) :: tmp !< + real(wp) :: nondim_time !< Non-dimensional time + real(wp) :: tmp !< !! Temporary variable to store quantity for mpi_allreduce - integer :: npts !< Number of included integral points + integer :: npts !< Number of included integral points real(wp) :: rad, thickness !< For integral quantities - logical :: trigger !< For integral quantities + logical :: trigger !< For integral quantities real(wp) :: rhoYks(1:num_species) T = dflt_T_guess @@ -1145,7 +1148,7 @@ contains ! Computing/Sharing necessary state variables if (elasticity) then call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, rho, gamma, pi_inf, qv, Re, G_local, & - & fluid_pp(:)%G) + & fluid_pp(:)%G) else call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, rho, gamma, pi_inf, qv) end if @@ -1162,11 +1165,11 @@ contains end if call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k, l), q_cons_vf(alf_idx)%sf(j - 2, k, l), dyn_p, pi_inf, & - & gamma, rho, qv, rhoYks(:), pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, k, l), & - & q_cons_vf(mom_idx%beg)%sf(j - 2, k, l), G_local) + & gamma, rho, qv, rhoYks(:), pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, k, l), & + & q_cons_vf(mom_idx%beg)%sf(j - 2, k, l), G_local) else call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k, l), q_cons_vf(alf_idx)%sf(j - 2, k, l), dyn_p, & - & pi_inf, gamma, rho, qv, rhoYks, pres, T) + & pi_inf, gamma, rho, qv, rhoYks, pres, T) end if if (model_eqns == 4) then @@ -1224,7 +1227,7 @@ contains ! Compute mixture sound Speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, & - & 0._wp, c, qv) + & 0._wp, c, qv) accel = accel_mag(j - 2, k, l) end if @@ -1253,7 +1256,7 @@ contains ! Computing/Sharing necessary state variables call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l, rho, gamma, pi_inf, qv, Re, G_local, & - & fluid_pp(:)%G) + & fluid_pp(:)%G) do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k - 2, l)/rho end do @@ -1267,12 +1270,11 @@ contains end if call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k - 2, l), q_cons_vf(alf_idx)%sf(j - 2, k - 2, l), & - & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, & - & q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l), & - & q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l), G_local) + & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l), & + & q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l), G_local) else call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l), q_cons_vf(alf_idx)%sf(j - 2, k - 2, l), & - & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) + & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) end if if (model_eqns == 4) then @@ -1306,7 +1308,7 @@ contains end if ! Compute mixture sound speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, & - & 0._wp, 0._wp, c, qv) + & 0._wp, 0._wp, c, qv) end if end if else ! 3D @@ -1334,7 +1336,7 @@ contains ! Computing/Sharing necessary state variables call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l - 2, rho, gamma, pi_inf, qv, Re, & - & G_local, fluid_pp(:)%G) + & G_local, fluid_pp(:)%G) do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k - 2, l - 2)/rho end do @@ -1354,17 +1356,16 @@ contains end if call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k - 2, l - 2), q_cons_vf(alf_idx)%sf(j - 2, k - 2, & - & l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, & - & q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l - 2), & - & q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l - 2), G_local) + & l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, & + & k - 2, l - 2), q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l - 2), G_local) else call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l - 2), q_cons_vf(alf_idx)%sf(j - 2, & - & k - 2, l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) + & k - 2, l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) end if ! Compute mixture sound speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, & - & 0._wp, 0._wp, c, qv) + & 0._wp, 0._wp, c, qv) accel = accel_mag(j - 2, k - 2, l - 2) end if @@ -1413,7 +1414,7 @@ contains if (bubbles_euler .and. (num_fluids <= 2)) then if (qbmm) then write (i + 30, '(6x,f12.6,14f28.16)') nondim_time, rho, vel(1), pres, alf, R(1), Rdot(1), nR(1), & - & nRdot(1), varR, varV, M10, M01, M20, M02 + & nRdot(1), varR, varV, M10, M01, M20, M02 else write (i + 30, '(6x,f12.6,8f24.8)') nondim_time, rho, vel(1), pres, alf, R(1), Rdot(1), nR(1), nRdot(1) ! ptilde, & @@ -1421,15 +1422,15 @@ contains end if else if (bubbles_euler .and. (num_fluids == 3)) then write (i + 30, & - & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8, f24.8)') & - & nondim_time, rho, vel(1), pres, alf, alfgr, nR(1), nRdot(1), R(1), Rdot(1), ptilde, ptot + & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8, f24.8)') nondim_time, & + & rho, vel(1), pres, alf, alfgr, nR(1), nRdot(1), R(1), Rdot(1), ptilde, ptot else if (bubbles_euler .and. num_fluids == 4) then write (i + 30, & - & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8)') & - & nondim_time, q_cons_vf(1)%sf(j - 2, 0, 0), q_cons_vf(2)%sf(j - 2, 0, 0), q_cons_vf(3)%sf(j - 2, & - & 0, 0), q_cons_vf(4)%sf(j - 2, 0, 0), q_cons_vf(5)%sf(j - 2, 0, 0), q_cons_vf(6)%sf(j - 2, 0, 0), & - & q_cons_vf(7)%sf(j - 2, 0, 0), q_cons_vf(8)%sf(j - 2, 0, 0), q_cons_vf(9)%sf(j - 2, 0, 0), & - & q_cons_vf(10)%sf(j - 2, 0, 0), nbub, R(1), Rdot(1) + & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8)') & + & nondim_time, q_cons_vf(1)%sf(j - 2, 0, 0), q_cons_vf(2)%sf(j - 2, 0, 0), q_cons_vf(3)%sf(j - 2, 0, & + & 0), q_cons_vf(4)%sf(j - 2, 0, 0), q_cons_vf(5)%sf(j - 2, 0, 0), q_cons_vf(6)%sf(j - 2, 0, 0), & + & q_cons_vf(7)%sf(j - 2, 0, 0), q_cons_vf(8)%sf(j - 2, 0, 0), q_cons_vf(9)%sf(j - 2, 0, 0), & + & q_cons_vf(10)%sf(j - 2, 0, 0), nbub, R(1), Rdot(1) else write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8)') nondim_time, rho, vel(1), pres end if @@ -1437,12 +1438,12 @@ contains if (bubbles_euler) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 write (i + 30, '(6X,10F24.8)') nondim_time, rho, vel(1), vel(2), pres, alf, nR(1), nRdot(1), R(1), & - & Rdot(1) + & Rdot(1) #:endif else if (elasticity) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,' // 'F24.8,F24.8,F24.8)') nondim_time, rho, & - & vel(1), vel(2), pres, tau_e(1), tau_e(2), tau_e(3) + & vel(1), vel(2), pres, tau_e(1), tau_e(2), tau_e(3) #:endif else write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8)') nondim_time, rho, vel(1), pres @@ -1451,8 +1452,8 @@ contains else #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 write (i + 30, & - & '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,' // 'F24.8,F24.8,F24.8,F24.8,F24.8,' // 'F24.8)') & - & nondim_time, rho, vel(1), vel(2), vel(3), pres, gamma, pi_inf, qv, c, accel + & '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,' // 'F24.8,F24.8,F24.8,F24.8,F24.8,' // 'F24.8)') nondim_time, & + & rho, vel(1), vel(2), vel(3), pres, gamma, pi_inf, qv, c, accel #:endif end if end if @@ -1484,7 +1485,7 @@ contains end do pres = ((q_cons_vf(E_idx)%sf(j, k, l) - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, k, & - & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma + & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma int_pres = int_pres + (pres - 1._wp)**2._wp end if end do @@ -1547,7 +1548,7 @@ contains end do pres = ((q_cons_vf(E_idx)%sf(j, k, l) - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, k, & - & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma + & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma int_pres = int_pres + abs(pres - 1._wp) max_pres = max(max_pres, abs(pres - 1._wp)) end if @@ -1577,6 +1578,7 @@ contains end if end if end subroutine s_write_probe_files + !> The goal of this subroutine is to write to the run-time information file basic footer information applicable to the current !! computation and to close the file when done. The footer contains the stability criteria extrema over all of the time-steps !! and the simulation run-time. @@ -1598,6 +1600,7 @@ contains write (3, '(A)') ' ' close (3) end subroutine s_close_run_time_information_file + !> Closes communication files impure subroutine s_close_com_files() integer :: i !< Generic loop iterator @@ -1605,6 +1608,7 @@ contains close (i + 120) end do end subroutine s_close_com_files + !> Closes probe files impure subroutine s_close_probe_files integer :: i !< Generic loop iterator @@ -1613,9 +1617,11 @@ contains close (i + 30) end do end subroutine s_close_probe_files + impure subroutine s_close_ib_state_file close (ib_state_unit) end subroutine s_close_ib_state_file + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_data_output_module @@ -1650,6 +1656,7 @@ contains end do end if end subroutine s_initialize_data_output_module + !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_data_output_module integer :: i diff --git a/src/simulation/m_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index 3192e3990c..5927a313a9 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -8,17 +8,11 @@ module m_derived_variables use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Data output module - use m_compile_specific - use m_helper - use m_finite_differences implicit none @@ -75,6 +69,7 @@ contains end if end if end subroutine s_initialize_derived_variables_module + !> Allocate and open derived variables. Computing FD coefficients. impure subroutine s_initialize_derived_variables if (probe_wrt) then @@ -97,6 +92,7 @@ contains end if end if end subroutine s_initialize_derived_variables + !> Writes coherent body information, communication files, and probes. !! @param t_step Current time-step !! @param q_cons_vf Conservative variables @@ -112,11 +108,11 @@ contains call s_derive_acceleration_component(1, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, x_accel) if (n > 0) then call s_derive_acceleration_component(2, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, & - & y_accel) + & y_accel) end if if (p > 0) then call s_derive_acceleration_component(3, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, & - & z_accel) + & z_accel) end if $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) @@ -144,6 +140,7 @@ contains call s_write_com_files(t_step, c_mass) end if end subroutine s_compute_derived_variables + !> This subroutine receives as inputs the indicator of the component of the acceleration that should be outputted and the !! primitive variables. From those inputs, it proceeds to calculate values of the desired acceleration component, which are !! subsequently stored in derived flow quantity storage variable, q_sf. @@ -169,7 +166,7 @@ contains do k = 0, n do j = 0, m q_sf(j, k, l) = (11._wp*q_prim_vf0(momxb)%sf(j, k, l) - 18._wp*q_prim_vf1(momxb)%sf(j, k, & - & l) + 9._wp*q_prim_vf2(momxb)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb)%sf(j, k, l))/(6._wp*dt) + & l) + 9._wp*q_prim_vf2(momxb)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb)%sf(j, k, l))/(6._wp*dt) end do end do end do @@ -182,7 +179,7 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) end do end do end do @@ -195,8 +192,8 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) end do end do end do @@ -210,9 +207,9 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & - & l)*q_prim_vf0(momxb)%sf(j, k, r + l)/y_cc(k) + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxb)%sf(j, k, r + l)/y_cc(k) end do end do end do @@ -225,9 +222,9 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & - & l)*q_prim_vf0(momxb)%sf(j, k, r + l) + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxb)%sf(j, k, r + l) end do end do end do @@ -242,7 +239,7 @@ contains do k = 0, n do j = 0, m q_sf(j, k, l) = (11._wp*q_prim_vf0(momxb + 1)%sf(j, k, l) - 18._wp*q_prim_vf1(momxb + 1)%sf(j, k, & - & l) + 9._wp*q_prim_vf2(momxb + 1)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb + 1)%sf(j, k, l))/(6._wp*dt) + & l) + 9._wp*q_prim_vf2(momxb + 1)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb + 1)%sf(j, k, l))/(6._wp*dt) end do end do end do @@ -255,8 +252,8 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) end do end do end do @@ -270,10 +267,10 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & - & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & - & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, & - & r + l)/y_cc(k) - (q_prim_vf0(momxe)%sf(j, k, l)**2._wp)/y_cc(k) + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & + & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & + & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, & + & r + l)/y_cc(k) - (q_prim_vf0(momxe)%sf(j, k, l)**2._wp)/y_cc(k) end do end do end do @@ -286,9 +283,9 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & - & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & - & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, r + l) + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & + & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & + & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, r + l) end do end do end do @@ -303,7 +300,7 @@ contains do k = 0, n do j = 0, m q_sf(j, k, l) = (11._wp*q_prim_vf0(momxe)%sf(j, k, l) - 18._wp*q_prim_vf1(momxe)%sf(j, k, & - & l) + 9._wp*q_prim_vf2(momxe)%sf(j, k, l) - 2._wp*q_prim_vf3(momxe)%sf(j, k, l))/(6._wp*dt) + & l) + 9._wp*q_prim_vf2(momxe)%sf(j, k, l) - 2._wp*q_prim_vf3(momxe)%sf(j, k, l))/(6._wp*dt) end do end do end do @@ -316,10 +313,10 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & - & l)*q_prim_vf0(momxe)%sf(j, k, r + l)/y_cc(k) + (q_prim_vf0(momxe)%sf(j, k, & - & l)*q_prim_vf0(momxb + 1)%sf(j, k, l))/y_cc(k) + & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxe)%sf(j, k, r + l)/y_cc(k) + (q_prim_vf0(momxe)%sf(j, k, & + & l)*q_prim_vf0(momxb + 1)%sf(j, k, l))/y_cc(k) end do end do end do @@ -332,9 +329,9 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & - & l)*q_prim_vf0(momxe)%sf(j, k, r + l) + & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxe)%sf(j, k, r + l) end do end do end do @@ -343,6 +340,7 @@ contains end if end if end subroutine s_derive_acceleration_component + !> This subroutine is used together with the volume fraction model and when called upon, it computes the location of of the !! center of mass for each fluid from the inputted primitive variables, q_prim_vf. The computed location is then written to a !! formatted data file by the root process. @@ -503,6 +501,7 @@ contains end do end if end subroutine s_derive_center_of_mass + !> Deallocation procedures for the module impure subroutine s_finalize_derived_variables_module ! Closing CoM and flow probe files diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 706a44b4c7..a61a032456 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -9,9 +9,7 @@ module m_fftw use, intrinsic :: iso_c_binding use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy #if defined(MFC_GPU) && defined(__PGI) @@ -33,7 +31,7 @@ module m_fftw type(c_ptr) :: fwd_plan, bwd_plan type(c_ptr) :: fftw_real_data, fftw_cmplx_data, fftw_fltr_cmplx_data integer :: real_size, cmplx_size, x_size, batch_size, Nfq - real(c_double), pointer :: data_real(:) !< Real data + real(c_double), pointer :: data_real(:) !< Real data complex(c_double_complex), pointer :: data_cmplx(:) !< !! Complex data in Fourier space @@ -108,24 +106,25 @@ contains #if defined(__PGI) ierr = cufftPlanMany(fwd_plan_gpu, rank, gpu_fft_size, iembed, istride, real_size, oembed, ostride, cmplx_size, & - & CUFFT_D2Z, batch_size) + & CUFFT_D2Z, batch_size) ierr = cufftPlanMany(bwd_plan_gpu, rank, gpu_fft_size, iembed, istride, cmplx_size, oembed, ostride, real_size, & - & CUFFT_Z2D, batch_size) + & CUFFT_Z2D, batch_size) #else ierr = hipfftPlanMany(fwd_plan_gpu, rank, gpu_fft_size, iembed, istride, real_size, oembed, ostride, cmplx_size, & - & HIPFFT_D2Z, batch_size) + & HIPFFT_D2Z, batch_size) ierr = hipfftPlanMany(bwd_plan_gpu, rank, gpu_fft_size, iembed, istride, cmplx_size, oembed, ostride, real_size, & - & HIPFFT_Z2D, batch_size) + & HIPFFT_Z2D, batch_size) #endif #endif end subroutine s_initialize_fftw_module + !> The purpose of this subroutine is to apply a Fourier low- pass filter to the flow variables in the azimuthal direction to !! remove the high-frequency content. This alleviates the restrictive CFL condition arising from cells near the axis. !! @param q_cons_vf Conservative variables impure subroutine s_apply_fourier_filter(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf integer :: i, j, k, l !< Generic loop iterators - integer :: ierr !< Generic flag used to identify and report GPU errors + integer :: ierr !< Generic flag used to identify and report GPU errors ! Restrict filter to processors that have cells adjacent to axis if (bc_y%beg >= 0) return @@ -167,7 +166,7 @@ contains do j = 0, m do l = 1, Nfq data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1) & - & *cmplx_size*x_size) + & *cmplx_size*x_size) end do end do end do @@ -187,7 +186,7 @@ contains do j = 0, m do l = 0, p data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k - 1) & - & *real_size*x_size)/real(real_size, dp) + & *real_size*x_size)/real(real_size, dp) q_cons_vf(k)%sf(j, 0, l) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) end do end do @@ -232,7 +231,7 @@ contains do j = 0, m do l = 1, Nfq data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k & - & - 1)*cmplx_size*x_size) + & - 1)*cmplx_size*x_size) end do end do end do @@ -252,7 +251,7 @@ contains do j = 0, m do l = 0, p data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k & - & - 1)*real_size*x_size)/real(real_size, dp) + & - 1)*real_size*x_size)/real(real_size, dp) q_cons_vf(k)%sf(j, i, l) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) end do end do @@ -290,6 +289,7 @@ contains end do #endif end subroutine s_apply_fourier_filter + !> The purpose of this subroutine is to destroy the fftw plan that will be used in the forward and backward DFTs when applying !! the Fourier filter in the azimuthal direction. impure subroutine s_finalize_fftw_module diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 675536af79..aab027d78b 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -12,7 +12,6 @@ module m_global_parameters #endif use m_derived_types !< Definitions of the derived types - use m_helper_basic !< Functions to compare floating point numbers ! $:USE_GPU_MODULE() @@ -23,10 +22,10 @@ module m_global_parameters real(wp) :: wall_time_avg = 0 ! Logistics - integer :: num_procs !< Number of processors - character(LEN=path_len) :: case_dir !< Case folder location - logical :: run_time_info !< Run-time output flag - integer :: t_step_old !< Existing IC/grid folder + integer :: num_procs !< Number of processors + character(LEN=path_len) :: case_dir !< Case folder location + logical :: run_time_info !< Run-time output flag + integer :: t_step_old !< Existing IC/grid folder ! Computational Domain Parameters integer :: proc_rank !< Rank of the local processor @@ -93,59 +92,59 @@ module m_global_parameters ! Simulation Algorithm Parameters integer :: model_eqns !< Multicomponent flow model #:if MFC_CASE_OPTIMIZATION - integer, parameter :: num_dims = ${num_dims}$ !< Number of spatial dimensions - integer, parameter :: num_vels = ${num_vels}$ !< Number of velocity components (different from num_dims for mhd) + integer, parameter :: num_dims = ${num_dims}$ !< Number of spatial dimensions + integer, parameter :: num_vels = ${num_vels}$ !< Number of velocity components (different from num_dims for mhd) #:else - integer :: num_dims !< Number of spatial dimensions - integer :: num_vels !< Number of velocity components (different from num_dims for mhd) + integer :: num_dims !< Number of spatial dimensions + integer :: num_vels !< Number of velocity components (different from num_dims for mhd) #:endif - logical :: mpp_lim !< Mixture physical parameters (MPP) limits - integer :: time_stepper !< Time-stepper algorithm + logical :: mpp_lim !< Mixture physical parameters (MPP) limits + integer :: time_stepper !< Time-stepper algorithm logical :: prim_vars_wrt #:if MFC_CASE_OPTIMIZATION - integer, parameter :: recon_type = ${recon_type}$ !< Reconstruction type - integer, parameter :: weno_polyn = ${weno_polyn}$ !< Degree of the WENO polynomials (polyn) + integer, parameter :: recon_type = ${recon_type}$ !< Reconstruction type + integer, parameter :: weno_polyn = ${weno_polyn}$ !< Degree of the WENO polynomials (polyn) integer, parameter :: muscl_polyn = ${muscl_polyn}$ !< Degree of the MUSCL polynomials (polyn) - integer, parameter :: weno_order = ${weno_order}$ !< Order of the WENO reconstruction + integer, parameter :: weno_order = ${weno_order}$ !< Order of the WENO reconstruction integer, parameter :: muscl_order = ${muscl_order}$ !< Order of the MUSCL order integer, & - & parameter :: weno_num_stencils = ${weno_num_stencils}$ !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) - integer, parameter :: muscl_lim = ${muscl_lim}$ !< MUSCL Limiter - integer, parameter :: num_fluids = ${num_fluids}$ !< number of fluids in the simulation - logical, parameter :: wenojs = (${wenojs}$ /= 0) !< WENO-JS (default) - logical, parameter :: mapped_weno = (${mapped_weno}$ /= 0) !< WENO-M (WENO with mapping of nonlinear weights) - logical, parameter :: wenoz = (${wenoz}$ /= 0) !< WENO-Z - logical, parameter :: teno = (${teno}$ /= 0) !< TENO (Targeted ENO) - real(wp), parameter :: wenoz_q = ${wenoz_q}$ !< Power constant for WENO-Z - logical, parameter :: mhd = (${mhd}$ /= 0) !< Magnetohydrodynamics - logical, parameter :: relativity = (${relativity}$ /= 0) !< Relativity (only for MHD) - integer, parameter :: igr_iter_solver = ${igr_iter_solver}$ !< IGR elliptic solver - integer, parameter :: igr_order = ${igr_order}$ !< Reconstruction order for IGR - logical, parameter :: igr = (${igr}$ /= 0) !< use information geometric regularization + & parameter :: weno_num_stencils = ${weno_num_stencils}$ !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) + integer, parameter :: muscl_lim = ${muscl_lim}$ !< MUSCL Limiter + integer, parameter :: num_fluids = ${num_fluids}$ !< number of fluids in the simulation + logical, parameter :: wenojs = (${wenojs}$ /= 0) !< WENO-JS (default) + logical, parameter :: mapped_weno = (${mapped_weno}$ /= 0) !< WENO-M (WENO with mapping of nonlinear weights) + logical, parameter :: wenoz = (${wenoz}$ /= 0) !< WENO-Z + logical, parameter :: teno = (${teno}$ /= 0) !< TENO (Targeted ENO) + real(wp), parameter :: wenoz_q = ${wenoz_q}$ !< Power constant for WENO-Z + logical, parameter :: mhd = (${mhd}$ /= 0) !< Magnetohydrodynamics + logical, parameter :: relativity = (${relativity}$ /= 0) !< Relativity (only for MHD) + integer, parameter :: igr_iter_solver = ${igr_iter_solver}$ !< IGR elliptic solver + integer, parameter :: igr_order = ${igr_order}$ !< Reconstruction order for IGR + logical, parameter :: igr = (${igr}$ /= 0) !< use information geometric regularization logical, parameter :: igr_pres_lim = (${igr_pres_lim}$ /= 0) !< Limit to positive pressures for IGR - logical, parameter :: viscous = (${viscous}$ /= 0) !< Viscous effects + logical, parameter :: viscous = (${viscous}$ /= 0) !< Viscous effects #:else - integer :: recon_type !< Reconstruction Type - integer :: weno_polyn !< Degree of the WENO polynomials (polyn) - integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn)i - integer :: weno_order !< Order of the WENO reconstruction - integer :: muscl_order !< Order of the MUSCL reconstruction - integer :: weno_num_stencils !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) - integer :: muscl_lim !< MUSCL Limiter - integer :: num_fluids !< number of fluids in the simulation - logical :: wenojs !< WENO-JS (default) - logical :: mapped_weno !< WENO-M (WENO with mapping of nonlinear weights) - logical :: wenoz !< WENO-Z - logical :: teno !< TENO (Targeted ENO) - real(wp) :: wenoz_q !< Power constant for WENO-Z - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity (only for MHD) - integer :: igr_iter_solver !< IGR elliptic solver - integer :: igr_order !< Reconstruction order for IGR - logical :: igr !< Use information geometric regularization - logical :: igr_pres_lim !< Limit to positive pressures for IGR - logical :: viscous !< Viscous effects + integer :: recon_type !< Reconstruction Type + integer :: weno_polyn !< Degree of the WENO polynomials (polyn) + integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn)i + integer :: weno_order !< Order of the WENO reconstruction + integer :: muscl_order !< Order of the MUSCL reconstruction + integer :: weno_num_stencils !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) + integer :: muscl_lim !< MUSCL Limiter + integer :: num_fluids !< number of fluids in the simulation + logical :: wenojs !< WENO-JS (default) + logical :: mapped_weno !< WENO-M (WENO with mapping of nonlinear weights) + logical :: wenoz !< WENO-Z + logical :: teno !< TENO (Targeted ENO) + real(wp) :: wenoz_q !< Power constant for WENO-Z + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity (only for MHD) + integer :: igr_iter_solver !< IGR elliptic solver + integer :: igr_order !< Reconstruction order for IGR + logical :: igr !< Use information geometric regularization + logical :: igr_pres_lim !< Limit to positive pressures for IGR + logical :: viscous !< Viscous effects #:endif !> @name Variables for our of core IGR computation on NVIDIA @@ -158,35 +157,35 @@ module m_global_parameters logical :: nv_uvm_pref_gpu ! Enable explicit gpu memory hints (default FALSE) !> @} - real(wp) :: weno_eps !< Binding for the WENO nonlinear weights - real(wp) :: teno_CT !< Smoothness threshold for TENO - logical :: mp_weno !< Monotonicity preserving (MP) WENO + real(wp) :: weno_eps !< Binding for the WENO nonlinear weights + real(wp) :: teno_CT !< Smoothness threshold for TENO + logical :: mp_weno !< Monotonicity preserving (MP) WENO logical :: weno_avg ! Average left/right cell-boundary states - logical :: weno_Re_flux !< WENO reconstruct velocity gradients for viscous stress tensor - integer :: riemann_solver !< Riemann solver algorithm - integer :: low_Mach !< Low Mach number fix to HLLC Riemann solver - integer :: wave_speeds !< Wave speeds estimation method - integer :: avg_state !< Average state evaluation method - logical :: alt_soundspeed !< Alternate mixture sound speed - logical :: null_weights !< Null undesired WENO weights - logical :: mixture_err !< Mixture properties correction - logical :: hypoelasticity !< hypoelasticity modeling - logical :: hyperelasticity !< hyperelasticity modeling - logical :: int_comp !< THINC interface compression - real(wp) :: ic_eps !< THINC Epsilon to compress on surface cells - real(wp) :: ic_beta !< THINC Sharpness Parameter - integer :: hyper_model !< hyperelasticity solver algorithm - logical :: elasticity !< elasticity modeling, true for hyper or hypo + logical :: weno_Re_flux !< WENO reconstruct velocity gradients for viscous stress tensor + integer :: riemann_solver !< Riemann solver algorithm + integer :: low_Mach !< Low Mach number fix to HLLC Riemann solver + integer :: wave_speeds !< Wave speeds estimation method + integer :: avg_state !< Average state evaluation method + logical :: alt_soundspeed !< Alternate mixture sound speed + logical :: null_weights !< Null undesired WENO weights + logical :: mixture_err !< Mixture properties correction + logical :: hypoelasticity !< hypoelasticity modeling + logical :: hyperelasticity !< hyperelasticity modeling + logical :: int_comp !< THINC interface compression + real(wp) :: ic_eps !< THINC Epsilon to compress on surface cells + real(wp) :: ic_beta !< THINC Sharpness Parameter + integer :: hyper_model !< hyperelasticity solver algorithm + logical :: elasticity !< elasticity modeling, true for hyper or hypo logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling - logical :: shear_stress !< Shear stresses - logical :: bulk_stress !< Bulk stresses - logical :: cont_damage !< Continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD for divB=0 - integer :: num_igr_iters !< number of iterations for elliptic solve - integer :: num_igr_warm_start_iters !< number of warm start iterations for elliptic solve - real(wp) :: alf_factor !< alpha factor for IGR + logical :: shear_stress !< Shear stresses + logical :: bulk_stress !< Bulk stresses + logical :: cont_damage !< Continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD for divB=0 + integer :: num_igr_iters !< number of iterations for elliptic solve + integer :: num_igr_warm_start_iters !< number of warm start iterations for elliptic solve + real(wp) :: alf_factor !< alpha factor for IGR logical :: bodyForces - logical :: bf_x, bf_y, bf_z !< body force toggle in three directions + logical :: bf_x, bf_y, bf_z !< body force toggle in three directions !< amplitude, frequency, and phase shift sinusoid in each direction #:for dir in {'x', 'y', 'z'} #:for param in {'k','w','p','g'} @@ -212,10 +211,10 @@ module m_global_parameters $:GPU_DECLARE(create='[hyperelasticity, hyper_model, elasticity, low_Mach]') $:GPU_DECLARE(create='[shear_stress, bulk_stress, cont_damage, hyper_cleaning]') - logical :: relax !< activate phase change - integer :: relax_model !< Relaxation model - real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model - real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model + logical :: relax !< activate phase change + integer :: relax_model !< Relaxation model + real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model + real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model $:GPU_DECLARE(create='[relax, relax_model, palpha_eps, ptgalpha_eps]') @@ -236,10 +235,10 @@ module m_global_parameters $:GPU_DECLARE(create='[x_domain, y_domain, z_domain]') real(wp) :: x_a, y_a, z_a real(wp) :: x_b, y_b, z_b - logical :: parallel_io !< Format of the data files + logical :: parallel_io !< Format of the data files logical :: file_per_process !< shared file or not when using parallel io - integer :: precision !< Precision of output files - logical :: down_sample !< down sample the output files + integer :: precision !< Precision of output files + logical :: down_sample !< down sample the output files $:GPU_DECLARE(create='[down_sample]') integer, allocatable, dimension(:) :: proc_coords !< @@ -264,26 +263,26 @@ module m_global_parameters !> @name Annotations of the structure of the state and flux vectors in terms of the size and the configuration of the system of !! equations to which they belong !> @{ - integer :: sys_size !< Number of unknowns in system of eqns. - type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. - type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of energy equation - integer :: n_idx !< Index of number density - type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. - type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. - type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: alf_idx !< Index of void fraction - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. - type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. - type(int_bounds_info) :: stress_idx !< Indexes of first and last shear stress eqns. - type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: b_size !< Number of elements in the symmetric b tensor, plus one - integer :: tensor_size !< Number of elements in the full tensor plus one - type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: c_idx !< Index of color function - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + integer :: sys_size !< Number of unknowns in system of eqns. + type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. + type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. + integer :: E_idx !< Index of energy equation + integer :: n_idx !< Index of number density + type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. + type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. + type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. + integer :: alf_idx !< Index of void fraction + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. + type(int_bounds_info) :: stress_idx !< Indexes of first and last shear stress eqns. + type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. + integer :: b_size !< Number of elements in the symmetric b tensor, plus one + integer :: tensor_size !< Number of elements in the full tensor plus one + type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. + integer :: c_idx !< Index of color function + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD !> @} $:GPU_DECLARE(create='[sys_size, E_idx, n_idx, bub_idx, alf_idx, gamma_idx]') $:GPU_DECLARE(create='[pi_inf_idx, B_idx, stress_idx, xi_idx, b_size]') @@ -409,24 +408,24 @@ module m_global_parameters integer :: nb !< Number of eq. bubble sizes #:endif - real(wp) :: Eu !< Euler number - real(wp) :: Ca !< Cavitation number - real(wp) :: Web !< Weber number - real(wp) :: Re_inv !< Inverse Reynolds number + real(wp) :: Eu !< Euler number + real(wp) :: Ca !< Cavitation number + real(wp) :: Web !< Weber number + real(wp) :: Re_inv !< Inverse Reynolds number $:GPU_DECLARE(create='[Eu, Ca, Web, Re_inv]') real(wp), dimension(:), allocatable :: weight !< Simpson quadrature weights real(wp), dimension(:), allocatable :: R0 !< Bubble sizes $:GPU_DECLARE(create='[weight, R0]') - logical :: bubbles_euler !< Bubbles euler on/off - logical :: polytropic !< Polytropic switch - logical :: polydisperse !< Polydisperse bubbles + logical :: bubbles_euler !< Bubbles euler on/off + logical :: polytropic !< Polytropic switch + logical :: polydisperse !< Polydisperse bubbles $:GPU_DECLARE(create='[bubbles_euler, polytropic, polydisperse]') - logical :: adv_n !< Solve the number density equation and compute alpha from number density - logical :: adap_dt !< Adaptive step size control - real(wp) :: adap_dt_tol !< Tolerance to control adaptive step size + logical :: adv_n !< Solve the number density equation and compute alpha from number density + logical :: adap_dt !< Adaptive step size control + real(wp) :: adap_dt_tol !< Tolerance to control adaptive step size integer :: adap_dt_max_iters !< Maximum number of iterations $:GPU_DECLARE(create='[adv_n, adap_dt, adap_dt_tol, adap_dt_max_iters]') @@ -434,14 +433,14 @@ module m_global_parameters integer :: thermal !< Thermal behavior. 1 = adiabatic, 2 = isotherm, 3 = transfer $:GPU_DECLARE(create='[bubble_model, thermal]') - real(wp), allocatable, dimension(:,:,:) :: ptil !< Pressure modification - real(wp) :: poly_sigma !< log normal sigma for polydisperse PDF + real(wp), allocatable, dimension(:,:,:) :: ptil !< Pressure modification + real(wp) :: poly_sigma !< log normal sigma for polydisperse PDF $:GPU_DECLARE(create='[ptil, poly_sigma]') - logical :: qbmm !< Quadrature moment method + logical :: qbmm !< Quadrature moment method integer, parameter :: nmom = 6 !< Number of carried moments per R0 location - integer :: nmomsp !< Number of moments required by ensemble-averaging - integer :: nmomtot !< Total number of carried moments moments/transport equations + integer :: nmomsp !< Number of moments required by ensemble-averaging + integer :: nmomtot !< Total number of carried moments moments/transport equations real(wp) :: pi_fac !< Factor for artificial pi_inf $:GPU_DECLARE(create='[qbmm, nmomsp, nmomtot, pi_fac]') @@ -472,15 +471,14 @@ module m_global_parameters $:GPU_DECLARE(create='[gam, gam_m]') real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g - $:GPU_DECLARE(create='[R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, & - gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g]') + $:GPU_DECLARE(create='[R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g]') !> @} !> @name Acoustic acoustic_source parameters !> @{ logical :: acoustic_source !< Acoustic source switch - type(acoustic_parameters), dimension(num_probes_max) :: acoustic !< Acoustic source parameters - integer :: num_source !< Number of acoustic sources + type(acoustic_parameters), dimension(num_probes_max) :: acoustic !< Acoustic source parameters + integer :: num_source !< Number of acoustic sources !> @} $:GPU_DECLARE(create='[acoustic_source, acoustic, num_source]') @@ -508,8 +506,8 @@ module m_global_parameters real(wp), allocatable, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps $:GPU_DECLARE(create='[gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps]') - real(wp) :: mytime !< Current simulation time - real(wp) :: finaltime !< Final simulation time + real(wp) :: mytime !< Current simulation time + real(wp) :: finaltime !< Final simulation time logical :: rdma_mpi type(pres_field), allocatable, dimension(:) :: pb_ts type(pres_field), allocatable, dimension(:) :: mv_ts @@ -518,8 +516,8 @@ module m_global_parameters !> @name lagrangian subgrid bubble parameters !> @{! - logical :: bubbles_lagrange !< Lagrangian subgrid bubble model switch - type(bubbles_lagrange_parameters) :: lag_params !< Lagrange bubbles' parameters + logical :: bubbles_lagrange !< Lagrangian subgrid bubble model switch + type(bubbles_lagrange_parameters) :: lag_params !< Lagrange bubbles' parameters $:GPU_DECLARE(create='[bubbles_lagrange, lag_params]') !> @} @@ -531,16 +529,16 @@ module m_global_parameters !> @name Continuum damage model parameters !> @{! - real(wp) :: tau_star !< Stress threshold for continuum damage modeling - real(wp) :: cont_damage_s !< Exponent s for continuum damage modeling - real(wp) :: alpha_bar !< Damage rate factor for continuum damage modeling + real(wp) :: tau_star !< Stress threshold for continuum damage modeling + real(wp) :: cont_damage_s !< Exponent s for continuum damage modeling + real(wp) :: alpha_bar !< Damage rate factor for continuum damage modeling $:GPU_DECLARE(create='[tau_star, cont_damage_s, alpha_bar]') !> @} !> @name MHD Hyperbolic cleaning parameters !> @{! - real(wp) :: hyper_cleaning_speed !< Hyperbolic cleaning wave speed (c_h) - real(wp) :: hyper_cleaning_tau !< Hyperbolic cleaning tau + real(wp) :: hyper_cleaning_speed !< Hyperbolic cleaning wave speed (c_h) + real(wp) :: hyper_cleaning_tau !< Hyperbolic cleaning tau $:GPU_DECLARE(create='[hyper_cleaning_speed, hyper_cleaning_tau]') !> @} contains @@ -882,6 +880,7 @@ contains patch_ib(i)%rotation_matrix_inverse = patch_ib(i)%rotation_matrix end do end subroutine s_assign_default_values_to_user_inputs + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_global_parameters_module @@ -1245,7 +1244,7 @@ contains end if call s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & - & bubbles_lagrange, m, n, p, num_dims, igr, ib) + & bubbles_lagrange, m, n, p, num_dims, igr, ib) $:GPU_UPDATE(device='[idwint, idwbuff]') ! Configuring Coordinate Direction Indexes @@ -1280,19 +1279,17 @@ contains chemxb = species_idx%beg chemxe = species_idx%end - $:GPU_UPDATE(device='[momxb,momxe,advxb,advxe,contxb,contxe, & - & bubxb, bubxe, intxb, intxe, sys_size, buff_size, E_idx, alf_idx, n_idx, adv_n, adap_dt, pi_fac, strxb, strxe, chemxb, & - & chemxe, c_idx, adap_dt_tol, adap_dt_max_iters]') + $:GPU_UPDATE(device='[momxb, momxe, advxb, advxe, contxb, contxe, bubxb, bubxe, intxb, intxe, sys_size, buff_size, E_idx, & + & alf_idx, n_idx, adv_n, adap_dt, pi_fac, strxb, strxe, chemxb, chemxe, c_idx, adap_dt_tol, adap_dt_max_iters]') $:GPU_UPDATE(device='[b_size, xibeg, xiend, tensor_size]') $:GPU_UPDATE(device='[species_idx]') $:GPU_UPDATE(device='[cfl_target, m, n, p]') $:GPU_UPDATE(device='[alt_soundspeed, acoustic_source, num_source]') - $:GPU_UPDATE(device='[dt,sys_size,buff_size,pref,rhoref, & - & gamma_idx, pi_inf_idx, E_idx, alf_idx, stress_idx, mpp_lim, bubbles_euler, hypoelasticity, alt_soundspeed, avg_state, & - & model_eqns, mixture_err, grid_geometry, cyl_coord, mp_weno, weno_eps, teno_CT, hyperelasticity, hyper_model, & - & elasticity, xi_idx, B_idx, low_Mach]') + $:GPU_UPDATE(device='[dt, sys_size, buff_size, pref, rhoref, gamma_idx, pi_inf_idx, E_idx, alf_idx, stress_idx, mpp_lim, & + & bubbles_euler, hypoelasticity, alt_soundspeed, avg_state, model_eqns, mixture_err, grid_geometry, cyl_coord, mp_weno, & + & weno_eps, teno_CT, hyperelasticity, hyper_model, elasticity, xi_idx, B_idx, low_Mach]') $:GPU_UPDATE(device='[Bx0]') @@ -1339,6 +1336,7 @@ contains @:PREFER_GPU(z_cc) @:PREFER_GPU(dz) end subroutine s_initialize_global_parameters_module + !> Initializes parallel infrastructure impure subroutine s_initialize_parallel_io #ifdef MFC_MPI @@ -1376,6 +1374,7 @@ contains allocate (start_idx(1:num_dims)) #endif end subroutine s_initialize_parallel_io + !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_global_parameters_module integer :: i diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index b78f718b55..68c83300f5 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -8,11 +8,8 @@ module m_hyperelastic use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion !< State variables type conversion procedures - use m_finite_differences implicit none @@ -71,6 +68,7 @@ contains $:GPU_UPDATE(device='[fd_coeff_z_hyper]') end if end subroutine s_initialize_hyperelastic_module + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. !! @param q_cons_vf Conservative variables !! @param q_prim_vf Primitive variables @@ -105,7 +103,7 @@ contains ! If in simulation, use acc mixture subroutines call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, alpha_k, alpha_rho_k, Re, G_local, & - & Gs_hyper) + & Gs_hyper) rho = max(rho, sgm_eps) G_local = max(G_local, sgm_eps) ! if ( G_local <= verysmall ) G_K = 0._wp @@ -148,7 +146,7 @@ contains ! STEP 2b: computing the determinant of the grad_xi tensor tensorb(tensor_size) = tensora(1)*(tensora(5)*tensora(9) - tensora(6)*tensora(8)) - tensora(2)*(tensora(4) & - & *tensora(9) - tensora(6)*tensora(7)) + tensora(3)*(tensora(4)*tensora(8) - tensora(5)*tensora(7)) + & *tensora(9) - tensora(6)*tensora(7)) + tensora(3)*(tensora(4)*tensora(8) - tensora(5)*tensora(7)) if (tensorb(tensor_size) > verysmall) then ! STEP 2c: computing the inverse of grad_xi tensor = F @@ -182,7 +180,7 @@ contains end if ! STEP 5b: updating the pressure field q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, l) - G_local*q_prim_vf(xiend + 1)%sf(j, k, & - & l)/gamma + & l)/gamma ! STEP 5c: updating the Cauchy stress conservative scalar field $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size - 1 @@ -195,6 +193,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_hyperelastic_rmt_stress_update + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. !! @param btensor_in Left Cauchy-Green deformation tensor !! @param q_prim_vf Primitive variables @@ -232,6 +231,7 @@ contains ! compute the invariant without the elastic modulus q_prim_vf(xiend + 1)%sf(j, k, l) = 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) end subroutine s_neoHookean_cauchy_solver + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. !! @param btensor_in Left Cauchy-Green deformation tensor !! @param q_prim_vf Primitive variables @@ -271,6 +271,7 @@ contains ! compute the invariant without the elastic modulus q_prim_vf(xiend + 1)%sf(j, k, l) = 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) end subroutine s_Mooney_Rivlin_cauchy_solver + !> @brief Deallocates memory for hyperelastic deformation tensor and finite-difference coefficients. impure subroutine s_finalize_hyperelastic_module() integer :: i !< iterator diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index 957f977f6b..0d23a53e35 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -73,6 +73,7 @@ contains $:GPU_UPDATE(device='[fd_coeff_z_hypo]') end if end subroutine s_initialize_hypoelastic_module + !> The purpose of this procedure is to compute the source terms that are needed for the elastic stress equations !! @param idir Dimension splitting index !! @param q_prim_vf Primitive variables @@ -83,7 +84,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf real(wp) :: rho_K, G_K integer :: i, k, l, q, r !< Loop variables - integer :: ndirs !< Number of coordinate directions + integer :: ndirs !< Number of coordinate directions ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 @@ -133,9 +134,9 @@ contains do r = -fd_number, fd_number du_dy_hypo(k, l, q) = du_dy_hypo(k, l, q) + q_prim_vf(momxb)%sf(k, l + r, q)*fd_coeff_y_hypo(r, l) dv_dx_hypo(k, l, q) = dv_dx_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k + r, l, & - & q)*fd_coeff_x_hypo(r, k) + & q)*fd_coeff_x_hypo(r, k) dv_dy_hypo(k, l, q) = dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l + r, & - & q)*fd_coeff_y_hypo(r, l) + & q)*fd_coeff_y_hypo(r, l) end do end do end do @@ -162,15 +163,15 @@ contains $:GPU_LOOP(parallelism='[seq]') do r = -fd_number, fd_number du_dz_hypo(k, l, q) = du_dz_hypo(k, l, q) + q_prim_vf(momxb)%sf(k, l, & - & q + r)*fd_coeff_z_hypo(r, q) + & q + r)*fd_coeff_z_hypo(r, q) dv_dz_hypo(k, l, q) = dv_dz_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, & - & q + r)*fd_coeff_z_hypo(r, q) + & q + r)*fd_coeff_z_hypo(r, q) dw_dx_hypo(k, l, q) = dw_dx_hypo(k, l, q) + q_prim_vf(momxe)%sf(k + r, l, & - & q)*fd_coeff_x_hypo(r, k) + & q)*fd_coeff_x_hypo(r, k) dw_dy_hypo(k, l, q) = dw_dy_hypo(k, l, q) + q_prim_vf(momxe)%sf(k, l + r, & - & q)*fd_coeff_y_hypo(r, l) + & q)*fd_coeff_y_hypo(r, l) dw_dz_hypo(k, l, q) = dw_dz_hypo(k, l, q) + q_prim_vf(momxe)%sf(k, l, & - & q + r)*fd_coeff_z_hypo(r, q) + & q + r)*fd_coeff_z_hypo(r, q) end do end do end do @@ -209,7 +210,7 @@ contains do l = 0, n do k = 0, m rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*((4._wp*G_K_field(k, l, & - & q)/3._wp) + q_prim_vf(strxb)%sf(k, l, q))*du_dx_hypo(k, l, q) + & q)/3._wp) + q_prim_vf(strxb)%sf(k, l, q))*du_dx_hypo(k, l, q) end do end do end do @@ -220,24 +221,23 @@ contains do l = 0, n do k = 0, m rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxb + 1)%sf(k, & - & l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy_hypo(k, l, & - & q) - q_prim_vf(strxb)%sf(k, l, q)*dv_dy_hypo(k, l, q) - 2._wp*G_K_field(k, l, & - & q)*(1._wp/3._wp)*dv_dy_hypo(k, l, q)) + & l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy_hypo(k, l, & + & q) - q_prim_vf(strxb)%sf(k, l, q)*dv_dy_hypo(k, l, q) - 2._wp*G_K_field(k, l, & + & q)*(1._wp/3._wp)*dv_dy_hypo(k, l, q)) rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & - & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, & - & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & - & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy_hypo(k, l, & - & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dy_hypo(k, l, q) + dv_dx_hypo(k, l, q))) + & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & + & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy_hypo(k, l, q) + 2._wp*G_K_field(k, & + & l, q)*(1._wp/2._wp)*(du_dy_hypo(k, l, q) + dv_dx_hypo(k, l, q))) rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & - & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*du_dx_hypo(k, l, & - & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & - & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, & - & q) + 2._wp*G_K_field(k, l, q)*(dv_dy_hypo(k, l, q) - (1._wp/3._wp)*(du_dx_hypo(k, l, & - & q) + dv_dy_hypo(k, l, q)))) + & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & + & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + 2._wp*G_K_field(k, & + & l, q)*(dv_dy_hypo(k, l, q) - (1._wp/3._wp)*(du_dx_hypo(k, l, q) + dv_dy_hypo(k, l, q)))) end do end do end do @@ -248,45 +248,45 @@ contains do l = 0, n do k = 0, m rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxb + 3)%sf(k, & - & l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz_hypo(k, l, & - & q) - q_prim_vf(strxb)%sf(k, l, q)*dw_dz_hypo(k, l, q) - 2._wp*G_K_field(k, l, & - & q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) + & l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz_hypo(k, l, & + & q) - q_prim_vf(strxb)%sf(k, l, q)*dw_dz_hypo(k, l, q) - 2._wp*G_K_field(k, l, & + & q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & - & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dz_hypo(k, l, q)) + & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & + & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dz_hypo(k, l, q)) rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & - & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dz_hypo(k, l, & - & q) - 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) + & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & + & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dz_hypo(k, l, q) - 2._wp*G_K_field(k, & + & l, q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & - & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, & - & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & - & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dy_hypo(k, l, & - & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & - & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz_hypo(k, l, & - & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dz_hypo(k, l, q) + dw_dx_hypo(k, l, q))) + & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & + & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, & + & l, q)*(1._wp/2._wp)*(du_dz_hypo(k, l, q) + dw_dx_hypo(k, l, q))) rhs_vf(strxb + 4)%sf(k, l, q) = rhs_vf(strxb + 4)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & - & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*du_dx_hypo(k, l, & - & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & - & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, & - & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & - & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz_hypo(k, l, & - & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(dv_dz_hypo(k, l, q) + dw_dy_hypo(k, l, q))) + & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, & + & l, q)*(1._wp/2._wp)*(dv_dz_hypo(k, l, q) + dw_dy_hypo(k, l, q))) rhs_vf(strxe)%sf(k, l, q) = rhs_vf(strxe)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxe - 2)%sf(k, & - & l, q)*dw_dx_hypo(k, l, q) + q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx_hypo(k, l, & - & q) - q_prim_vf(strxe)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, & - & q)*dw_dy_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy_hypo(k, l, & - & q) - q_prim_vf(strxe)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxe)%sf(k, l, & - & q)*dw_dz_hypo(k, l, q) + q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, & - & q) - q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, l, q)*(dw_dz_hypo(k, & - & l, q) - (1._wp/3._wp)*(du_dx_hypo(k, l, q) + dv_dy_hypo(k, l, q) + dw_dz_hypo(k, l, q)))) + & l, q)*dw_dx_hypo(k, l, q) + q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx_hypo(k, l, & + & q) - q_prim_vf(strxe)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy_hypo(k, l, & + & q) - q_prim_vf(strxe)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, & + & l, q) + q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxe)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, l, q)*(dw_dz_hypo(k, l, & + & q) - (1._wp/3._wp)*(du_dx_hypo(k, l, q) + dv_dy_hypo(k, l, q) + dw_dz_hypo(k, l, q)))) end do end do end do @@ -300,29 +300,30 @@ contains do k = 0, m ! S_xx -= rho * v/r * (tau_xx + 2/3*G) rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) - rho_K_field(k, l, q)*q_prim_vf(momxb + 1)%sf(k, & - & l, q)/y_cc(l)*(q_prim_vf(strxb)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_xx + 2/3*G + & l, q)/y_cc(l)*(q_prim_vf(strxb)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_xx + 2/3*G ! S_xr -= rho * v/r * tau_xr rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) - rho_K_field(k, l, & - & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*q_prim_vf(strxb + 1)%sf(k, l, q) ! tau_xx + & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*q_prim_vf(strxb + 1)%sf(k, l, q) ! tau_xx ! S_rr -= rho * v/r * (tau_rr + 2/3*G) rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) - rho_K_field(k, l, & - & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*(q_prim_vf(strxb + 2)%sf(k, l, & - & q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_rr + 2/3*G + & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*(q_prim_vf(strxb + 2)%sf(k, l, & + & q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_rr + 2/3*G ! S_thetatheta += rho * ( -(tau_thetatheta + 2/3*G)*(du/dx + dv/dr + v/r) + 2*(tau_thetatheta + G)*v/r ) rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(-(q_prim_vf(strxb + 3)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q))*(du_dx_hypo(k, l, & - & q) + dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, & - & q)/y_cc(l)) + 2._wp*(q_prim_vf(strxb + 3)%sf(k, l, q) + G_K_field(k, l, & - & q))*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)) + & q)*(-(q_prim_vf(strxb + 3)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q))*(du_dx_hypo(k, l, & + & q) + dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, & + & q)/y_cc(l)) + 2._wp*(q_prim_vf(strxb + 3)%sf(k, l, q) + G_K_field(k, l, & + & q))*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)) end do end do end do $:END_GPU_PARALLEL_LOOP() end if end subroutine s_compute_hypoelastic_rhs + !> @brief Deallocates arrays used by the hypoelastic stress module. impure subroutine s_finalize_hypoelastic_module() @:DEALLOCATE(Gs_hypo) @@ -338,6 +339,7 @@ contains end if end if end subroutine s_finalize_hypoelastic_module + !> @brief Computes the continuum damage source term from the principal stress state. subroutine s_compute_damage_state(q_cons_vf, rhs_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -352,7 +354,7 @@ contains $:GPU_PARALLEL_LOOP() do k = 0, m rhs_vf(damage_idx)%sf(k, l, q) = (alpha_bar*max(abs(real(q_cons_vf(stress_idx%beg)%sf(k, l, q), & - & kind=wp)) - tau_star, 0._wp))**cont_damage_s + & kind=wp)) - tau_star, 0._wp))**cont_damage_s end do $:END_GPU_PARALLEL_LOOP() else if (p == 0) then @@ -362,8 +364,8 @@ contains do k = 0, m ! Maximum principal stress tau_p = 0.5_wp*(q_cons_vf(stress_idx%beg)%sf(k, l, q) + q_cons_vf(stress_idx%beg + 2)%sf(k, l, & - & q)) + sqrt((q_cons_vf(stress_idx%beg)%sf(k, l, q) - q_cons_vf(stress_idx%beg + 2)%sf(k, l, & - & q))**2.0_wp + 4._wp*q_cons_vf(stress_idx%beg + 1)%sf(k, l, q)**2.0_wp)/2._wp + & q)) + sqrt((q_cons_vf(stress_idx%beg)%sf(k, l, q) - q_cons_vf(stress_idx%beg + 2)%sf(k, l, & + & q))**2.0_wp + 4._wp*q_cons_vf(stress_idx%beg + 1)%sf(k, l, q)**2.0_wp)/2._wp rhs_vf(damage_idx)%sf(k, l, q) = (alpha_bar*max(tau_p - tau_star, 0._wp))**cont_damage_s end do diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index 130b858c4a..179982ca05 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -12,15 +12,10 @@ !> @brief Immersed boundary patch geometry constructors for 2D and 3D shapes module m_ib_patches use m_model ! Subroutine(s) related to STL files - use m_derived_types ! Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_helper_basic !< Functions to compare floating point numbers - use m_helper - use m_mpi_common implicit none @@ -114,6 +109,7 @@ contains !> @} end if end subroutine s_apply_ib_patches + !> The circular patch is a 2D geometry that may be used, for example, in creating a bubble or a droplet. The geometry of the !! patch is well-defined when its centroid and radius are provided. Note that the circular patch DOES allow for the smoothing of !! its boundary. @@ -122,7 +118,7 @@ contains !! @param ib True if this patch is an immersed boundary subroutine s_ib_circle(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information type(integer_field), intent(inout) :: ib_markers real(wp), dimension(1:2) :: center real(wp) :: radius @@ -161,20 +157,21 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_circle + !> @brief Marks cells inside a 2D NACA 4-digit airfoil immersed boundary using upper and lower surface grids. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_airfoil(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information real(wp) :: f, ca_in, pa, ma, ta real(wp) :: xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c integer :: i, j, k, il, ir, jl, jr integer :: Np1, Np2 integer :: encoded_patch_id real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) @@ -319,6 +316,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_airfoil + !> @brief Marks cells inside a 3D extruded NACA 4-digit airfoil immersed boundary with finite span. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids @@ -429,7 +427,7 @@ contains do j = jl, jr do i = il, ir xyz_local = [x_cc(i) - center(1), y_cc(j) - center(2), & - & z_cc(l) - center(3)] ! get coordinate frame centered on IB + & z_cc(l) - center(3)] ! get coordinate frame centered on IB xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates xyz_local = xyz_local - offset ! airfoils are a patch that require a centroid offset @@ -478,6 +476,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_3D_airfoil + !> The rectangular patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock !! region, in alignment with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x- and y- coordinate directions are provided. Please note that the rectangular patch DOES NOT @@ -488,12 +487,12 @@ contains subroutine s_ib_rectangle(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information integer :: i, j, il, ir, jl, jr !< generic loop iterators integer :: encoded_patch_id - real(wp) :: corner_distance !< Equation of state parameters - real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: length, center !< x and y coordinates in local IB frame + real(wp) :: corner_distance !< Equation of state parameters + real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: length, center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation ! Transferring the rectangle's centroid and length information @@ -535,6 +534,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_rectangle + !> The spherical patch is a 3D geometry that may be used, for example, in creating a bubble or a droplet. The patch geometry is !! well-defined when its centroid and radius are provided. Please note that the spherical patch DOES allow for the smoothing of !! its boundary. @@ -601,6 +601,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_sphere + !> The cuboidal patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post-shock region, !! which is aligned with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x-, y- and z-coordinate directions are provided. Please notice that the cuboidal patch DOES NOT @@ -671,6 +672,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_cuboid + !> The cylindrical patch is a 3D geometry that may be used, for example, in setting up a cylindrical solid boundary confinement, !! like a blood vessel. The geometry of this patch is well-defined when the centroid, the radius and the length along the !! cylinder's axis, parallel to the x-, y- or z-coordinate direction, are provided. Please note that the cylindrical patch DOES @@ -745,16 +747,17 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_cylinder + !> @brief Marks cells inside a 2D elliptical immersed boundary defined by semi-axis lengths and rotation. subroutine s_ib_ellipse(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information integer :: i, j, il, ir, jl, jr !< Generic loop iterators integer :: encoded_patch_id - real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: ellipse_coeffs !< a and b in the ellipse coefficients - real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: ellipse_coeffs !< a and b in the ellipse coefficients + real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation ! Transferring the ellipse's centroid and length information @@ -794,14 +797,15 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_ellipse + !> The STL patch is a 2D geometry that is imported from an STL file. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_model(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information - integer :: i, j, k, il, ir, jl, jr !< Generic loop iterators + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer :: i, j, k, il, ir, jl, jr !< Generic loop iterators integer :: spc, encoded_patch_id integer :: cx, cy real(wp) :: lx(2), ly(2) @@ -871,6 +875,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_model + !> The STL patch is a 3D geometry that is imported from an STL file. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids @@ -958,6 +963,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_ib_3d_model + !> Subroutine that computes a rotation matrix for converting to the rotating frame of the boundary subroutine s_update_ib_rotation_matrix(patch_id) integer, intent(in) :: patch_id @@ -993,13 +999,14 @@ contains ! apply the z rotation to the xy rotation in 3D patch_ib(patch_id)%rotation_matrix(:,:) = matmul(patch_ib(patch_id)%rotation_matrix(:,:), rotation(3,:,:)) patch_ib(patch_id)%rotation_matrix_inverse(:,:) = matmul(transpose(rotation(3,:,:)), & - & patch_ib(patch_id)%rotation_matrix_inverse(:,:)) + & patch_ib(patch_id)%rotation_matrix_inverse(:,:)) else ! write out only the z rotation in 2D patch_ib(patch_id)%rotation_matrix(:,:) = rotation(3,:,:) patch_ib(patch_id)%rotation_matrix_inverse(:,:) = transpose(rotation(3,:,:)) end if end subroutine s_update_ib_rotation_matrix + !> @brief Converts cylindrical (r, theta) coordinates to Cartesian (y, z) and stores in module variables. subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) $:GPU_ROUTINE(parallelism='[seq]') @@ -1009,6 +1016,7 @@ contains cart_y = cyl_y*sin(cyl_z) cart_z = cyl_y*cos(cyl_z) end subroutine s_convert_cylindrical_to_cartesian_coord + !> @brief Converts a 3D cylindrical coordinate vector (x, r, theta) to Cartesian (x, y, z). pure function f_convert_cyl_to_cart(cyl) result(cart) $:GPU_ROUTINE(parallelism='[seq]') @@ -1018,6 +1026,7 @@ contains cart = (/cyl(1), cyl(2)*sin(cyl(3)), cyl(2)*cos(cyl(3))/) end function f_convert_cyl_to_cart + !> @brief Converts cylindrical coordinates (x, r) to the spherical azimuthal angle phi and stores in a module variable. subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) $:GPU_ROUTINE(parallelism='[seq]') @@ -1026,6 +1035,7 @@ contains sph_phi = atan(cyl_y/cyl_x) end subroutine s_convert_cylindrical_to_spherical_coord + subroutine get_bounding_indices(left_bound, right_bound, cell_centers, left_index, right_index) real(wp), intent(in) :: left_bound, right_bound integer, intent(inout) :: left_index, right_index @@ -1062,6 +1072,7 @@ contains end do right_index = itr_right end subroutine get_bounding_indices + !> @brief encodes the patch id with a unique offset that contains information on how the IB marker wraps periodically subroutine s_encode_patch_periodicity(patch_id, x_periodicity, y_periodicity, z_periodicity, encoded_patch_id) integer, intent(in) :: patch_id, x_periodicity, y_periodicity, z_periodicity @@ -1077,6 +1088,7 @@ contains offset = (num_ibs + 1)*temp_x_per + 3*(num_ibs + 1)*temp_y_per + 9*(num_ibs + 1)*temp_z_per encoded_patch_id = patch_id + offset end subroutine s_encode_patch_periodicity + !> @brief decodes the encoded id to get out the original id and the way in which it is periodic subroutine s_decode_patch_periodicity(encoded_patch_id, patch_id, x_periodicity, y_periodicity, z_periodicity) $:GPU_ROUTINE(parallelism='[seq]') @@ -1100,6 +1112,7 @@ contains y_periodicity = yp; if (yp == 2) y_periodicity = -1 z_periodicity = zp; if (zp == 2) z_periodicity = -1 end subroutine s_decode_patch_periodicity + !> @brief Determines if we should wrap periodically subroutine s_get_periodicities(xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper) integer, intent(out) :: xp_lower, xp_upper, yp_lower, yp_upper @@ -1129,6 +1142,7 @@ contains end if end if end subroutine s_get_periodicities + !> Archimedes spiral function !! @param myth Angle !! @param offset Thickness diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 96e484c1fc..e1f23b628a 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -8,25 +8,15 @@ !! flow state module m_ibm use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_helper - use m_helper_basic !< Functions to compare floating point numbers - use m_constants - use m_compute_levelset - use m_ib_patches - use m_viscous - use m_model implicit none @@ -64,6 +54,7 @@ contains $:GPU_ENTER_DATA(copyin='[num_gps]') end subroutine s_initialize_ibm_module + !> Initializes the values of various IBM variables, such as ghost points and image points. impure subroutine s_ibm_setup() integer :: i, j, k @@ -123,6 +114,7 @@ contains call nvtxEndRange end subroutine s_ibm_setup + !> Subroutine that updates the conservative variables at the ghost points !! @param pb_in Internal bubble pressure !! @param mv_in Mass of vapor in bubble @@ -155,10 +147,10 @@ contains !! Primitive variables at the image point associated with a ghost point, !! interpolated from surrounding fluid cells. - real(wp), dimension(3) :: norm !< Normal vector from GP to IP - real(wp), dimension(3) :: physical_loc !< Physical loc of GP - real(wp), dimension(3) :: vel_g !< Velocity of GP - real(wp), dimension(3) :: radial_vector !< vector from centroid to ghost point + real(wp), dimension(3) :: norm !< Normal vector from GP to IP + real(wp), dimension(3) :: physical_loc !< Physical loc of GP + real(wp), dimension(3) :: vel_g !< Velocity of GP + real(wp), dimension(3) :: radial_vector !< vector from centroid to ghost point real(wp), dimension(3) :: rotation_velocity !< speed of the ghost point due to rotation real(wp) :: nbub real(wp) :: buf @@ -210,13 +202,13 @@ contains ! Interpolate primitive variables at image point associated w/ GP if (bubbles_euler .and. .not. qbmm) then call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & - & pb_IP, mv_IP) + & pb_IP, mv_IP) else if (qbmm .and. polytropic) then call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & - & pb_IP, mv_IP, nmom_IP) + & pb_IP, mv_IP, nmom_IP) else if (qbmm .and. .not. polytropic) then call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & - & pb_IP, mv_IP, nmom_IP, pb_in, mv_in, presb_IP, massv_IP) + & pb_IP, mv_IP, nmom_IP, pb_in, mv_in, presb_IP, massv_IP) else call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP) end if @@ -244,8 +236,8 @@ contains ! Se the pressure inside a moving immersed boundary based upon the pressure of the image point. ! acceleration, and normal vector direction q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, & - & l) + pres_IP/(1._wp - 2._wp*abs(gp%levelset*alpha_rho_IP(q)/pres_IP) & - & *dot_product(patch_ib(patch_id)%force/patch_ib(patch_id)%mass, gp%levelset_norm)) + & l) + pres_IP/(1._wp - 2._wp*abs(gp%levelset*alpha_rho_IP(q)/pres_IP)*dot_product(patch_ib(patch_id) & + & %force/patch_ib(patch_id)%mass, gp%levelset_norm)) end do end if @@ -253,7 +245,7 @@ contains ! If in simulation, use acc mixture subroutines if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, alpha_rho_IP, Re_K, & - & G_K, Gs) + & G_K, Gs) else call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, alpha_rho_IP, Re_K) end if @@ -269,9 +261,9 @@ contains if (patch_ib(patch_id)%moving_ibm /= 0) then ! compute the linear velocity of the ghost point due to rotation radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, patch_ib(patch_id)%y_centroid, & - & patch_ib(patch_id)%z_centroid] + & patch_ib(patch_id)%z_centroid] call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), & - & radial_vector, rotation_velocity) + & radial_vector, rotation_velocity) ! add only the component of the IB's motion that is normal to the surface vel_g = vel_g + sum((patch_ib(patch_id)%vel + rotation_velocity)*norm)*norm @@ -283,11 +275,11 @@ contains else ! get the vector that points from the centroid to the ghost radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, patch_ib(patch_id)%y_centroid, & - & patch_ib(patch_id)%z_centroid] + & patch_ib(patch_id)%z_centroid] ! convert the angular velocity from the inertial reference frame to the fluids frame, then convert to linear ! velocity call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), & - & radial_vector, rotation_velocity) + & radial_vector, rotation_velocity) do q = 1, 3 ! if mibm is 1 or 2, then the boundary may be moving vel_g(q) = patch_ib(patch_id)%vel(q) ! add the linear velocity @@ -371,6 +363,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_ibm_correct_state + !> Function that computes the image points for each ghost point !! @param ghost_points_in Ghost Points impure subroutine s_compute_image_points(ghost_points_in) @@ -382,9 +375,9 @@ contains real(wp), pointer, dimension(:) :: s_cc => null() integer :: bound type(ghost_point) :: gp - integer :: q, dim !< Iterator variables + integer :: q, dim !< Iterator variables integer :: i, j, k, l !< Location indexes - integer :: patch_id !< IB Patch ID + integer :: patch_id !< IB Patch ID integer :: dir integer :: index logical :: bounds_error @@ -454,12 +447,11 @@ contains print *, "y: ", y_cc(-buff_size), " to: ", y_cc(n + buff_size - 1) if (p /= 0) print *, "z: ", z_cc(-buff_size), " to: ", z_cc(p + buff_size - 1) print *, "Image point is located approximately ", & - & (ghost_points_in(q)%loc(dim) - ghost_points_in(q) & - & %ip_loc(dim))/(s_cc(1) - s_cc(0)), & - & " grid cells away" + & (ghost_points_in(q)%loc(dim) - ghost_points_in(q) %ip_loc(dim))/(s_cc(1) - s_cc(0)), & + & " grid cells away" print *, "Levelset ", dist, " and Norm: ", norm(:) print *, & - & "A short term fix may include increasing buff_size further in m_helper_basic (currently set to a minimum of 10)" + & "A short term fix may include increasing buff_size further in m_helper_basic (currently set to a minimum of 10)" #endif bounds_error = .true. end if @@ -478,11 +470,12 @@ contains if (bounds_error) error stop "Ghost Point and Image Point on Different Processors. Exiting" end subroutine s_compute_image_points + !> Subroutine that finds the number of ghost points, used for allocating memory. subroutine s_find_num_ghost_points(num_gps_out) integer, intent(out) :: num_gps_out integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables - integer :: num_gps_local !< local copies of the gp count to support GPU compute + integer :: num_gps_local !< local copies of the gp count to support GPU compute logical :: is_gp num_gps_local = 0 @@ -520,11 +513,12 @@ contains num_gps_out = num_gps_local end subroutine s_find_num_ghost_points + !> Function that finds the ghost points subroutine s_find_ghost_points(ghost_points_in) type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables - integer :: xp, yp, zp !< periodicities + integer :: xp, yp, zp !< periodicities integer :: count, count_i, local_idx integer :: patch_id, encoded_patch_id logical :: is_gp @@ -535,7 +529,7 @@ contains if (p == 0) gp_layers_z = 0 $:GPU_PARALLEL_LOOP(private='[i, j, k, ii, jj, kk, is_gp, local_idx, patch_id, encoded_patch_id, xp, yp, zp]', & - & copyin='[count, count_i, x_domain, y_domain, z_domain]', firstprivate='[gp_layers, gp_layers_z]', collapse=3) + & copyin='[count, count_i, x_domain, y_domain, z_domain]', firstprivate='[gp_layers, gp_layers_z]', collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -601,6 +595,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_find_ghost_points + !> Function that computes the interpolation coefficients of image points subroutine s_compute_interpolation_coeffs(ghost_points_in) type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in @@ -636,8 +631,8 @@ contains else do kk = 0, 1 dist(1 + ii, 1 + jj, & - & 1 + kk) = sqrt((x_cc(i + ii) - gp%ip_loc(1))**2 + (y_cc(j + jj) - gp%ip_loc(2))**2 + (z_cc(k & - & + kk) - gp%ip_loc(3))**2) + & 1 + kk) = sqrt((x_cc(i + ii) - gp%ip_loc(1))**2 + (y_cc(j + jj) - gp%ip_loc(2))**2 + (z_cc(k & + & + kk) - gp%ip_loc(3))**2) end do end if end do @@ -704,6 +699,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_compute_interpolation_coeffs + !> Function that uses the interpolation coefficients and the current state at the cell centers in order to estimate the state at !! the image point !! @param gp Ghost point data structure @@ -724,7 +720,7 @@ contains !! @param presb_IP Bubble node pressure at image point !! @param massv_IP Bubble node vapor mass at image point subroutine s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, pb_IP, mv_IP, & - & nmom_IP, pb_in, mv_in, presb_IP, massv_IP) + & nmom_IP, pb_in, mv_in, presb_IP, massv_IP) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !< Primitive Variables real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(in) :: pb_in, mv_in @@ -740,7 +736,7 @@ contains real(wp), optional, dimension(:), intent(inout) :: r_IP, v_IP, pb_IP, mv_IP real(wp), optional, dimension(:), intent(inout) :: nmom_IP real(wp), optional, dimension(:), intent(inout) :: presb_IP, massv_IP - integer :: i, j, k, l, q !< Iterator variables + integer :: i, j, k, l, q !< Iterator variables integer :: i1, i2, j1, j2, k1, k2 !< Iterator variables real(wp) :: coeff @@ -825,9 +821,9 @@ contains do q = 1, nb do l = 1, nnode presb_IP((q - 1)*nnode + l) = presb_IP((q - 1)*nnode + l) + coeff*real(pb_in(i, j, k, l, q), & - & kind=wp) + & kind=wp) massv_IP((q - 1)*nnode + l) = massv_IP((q - 1)*nnode + l) + coeff*real(mv_in(i, j, k, l, q), & - & kind=wp) + & kind=wp) end do end do end if @@ -836,6 +832,7 @@ contains end do end do end subroutine s_interpolate_image_point + !> Resets the current indexes of immersed boundaries and replaces them after updating !> the position of each moving immersed boundary impure subroutine s_update_mib(num_ibs) @@ -880,6 +877,7 @@ contains call nvtxEndRange end subroutine s_update_mib + !> @brief Computes pressure and viscous forces and torques on immersed bodies via a volume integration method. subroutine s_compute_ib_forces(q_prim_vf, fluid_pp) ! real(wp), dimension(idwbuff(1)%beg:idwbuff(1)%end, & @@ -890,7 +888,7 @@ contains integer :: gp_id, i, j, k, l, q, ib_idx, fluid_idx real(wp), dimension(num_ibs, 3) :: forces, torques real(wp), dimension(1:3, 1:3) :: viscous_stress_div, viscous_stress_div_1, & - & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations + & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations real(wp), dimension(1:3) :: local_force_contribution, radial_vector, local_torque_contribution, vel real(wp) :: cell_volume, dx, dy, dz, dynamic_viscosity #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -925,10 +923,10 @@ contains ! get the vector pointing to the grid cell from the IB centroid if (num_dims == 3) then radial_vector = [x_cc(i), y_cc(j), z_cc(k)] - [patch_ib(ib_idx)%x_centroid, & - & patch_ib(ib_idx)%y_centroid, patch_ib(ib_idx)%z_centroid] + & patch_ib(ib_idx)%y_centroid, patch_ib(ib_idx)%z_centroid] else radial_vector = [x_cc(i), y_cc(j), 0._wp] - [patch_ib(ib_idx)%x_centroid, & - & patch_ib(ib_idx)%y_centroid, 0._wp] + & patch_ib(ib_idx)%y_centroid, 0._wp] end if dx = x_cc(i + 1) - x_cc(i) dy = y_cc(j + 1) - y_cc(j) @@ -938,16 +936,16 @@ contains ! Get the pressure contribution to force via a finite difference to compute the 2D components of the ! gradient of the pressure and cell volume local_force_contribution(1) = local_force_contribution(1) - (q_prim_vf(E_idx + fluid_idx)%sf(i + 1, & - & j, k) - q_prim_vf(E_idx + fluid_idx)%sf(i - 1, j, & - & k))/(2._wp*dx) ! force is the negative pressure gradient + & j, k) - q_prim_vf(E_idx + fluid_idx)%sf(i - 1, j, & + & k))/(2._wp*dx) ! force is the negative pressure gradient local_force_contribution(2) = local_force_contribution(2) - (q_prim_vf(E_idx + fluid_idx)%sf(i, & - & j + 1, k) - q_prim_vf(E_idx + fluid_idx)%sf(i, j - 1, k))/(2._wp*dy) + & j + 1, k) - q_prim_vf(E_idx + fluid_idx)%sf(i, j - 1, k))/(2._wp*dy) cell_volume = abs(dx*dy) ! add the 3D component of the pressure gradient, if we are working in 3 dimensions if (num_dims == 3) then dz = z_cc(k + 1) - z_cc(k) local_force_contribution(3) = local_force_contribution(3) - (q_prim_vf(E_idx + fluid_idx)%sf(i, & - & j, k + 1) - q_prim_vf(E_idx + fluid_idx)%sf(i, j, k - 1))/(2._wp*dz) + & j, k + 1) - q_prim_vf(E_idx + fluid_idx)%sf(i, j, k - 1))/(2._wp*dz) cell_volume = abs(cell_volume*dz) end if end do @@ -959,33 +957,33 @@ contains do fluid_idx = 1, num_fluids ! local dynamic viscosity is the dynamic viscosity of the fluid times alpha of the fluid dynamic_viscosity = dynamic_viscosity + (q_prim_vf(fluid_idx + advxb - 1)%sf(i, j, & - & k)*dynamic_viscosities(fluid_idx)) + & k)*dynamic_viscosities(fluid_idx)) end do ! get the linear force components first call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i - 1, j, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i + 1, j, k) viscous_stress_div(1, 1:3) = (viscous_stress_div_2(1, 1:3) - viscous_stress_div_1(1, & - & 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor + & 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(1, & - & 1:3) ! add the x components of the divergence to the force + & 1:3) ! add the x components of the divergence to the force call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j - 1, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j + 1, k) viscous_stress_div(2, 1:3) = (viscous_stress_div_2(2, 1:3) - viscous_stress_div_1(2, & - & 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor + & 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(2, & - & 1:3) ! add the y components of the divergence to the force + & 1:3) ! add the y components of the divergence to the force if (num_dims == 3) then call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j, & - & k - 1) + & k - 1) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j, & - & k + 1) + & k + 1) viscous_stress_div(3, 1:3) = (viscous_stress_div_2(3, 1:3) - viscous_stress_div_1(3, & - & 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor + & 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(3, & - & 1:3) ! add the z components of the divergence to the force + & 1:3) ! add the z components of the divergence to the force end if end if @@ -1025,11 +1023,12 @@ contains do i = 1, num_ibs patch_ib(i)%force(:) = forces(i,:) patch_ib(i)%torque(:) = matmul(patch_ib(i)%rotation_matrix_inverse, torques(i, & - & :)) ! torques must be converted to the local coordinates of the IB + & :)) ! torques must be converted to the local coordinates of the IB end do call nvtxEndRange end subroutine s_compute_ib_forces + !> Subroutine to deallocate memory reserved for the IBM module impure subroutine s_finalize_ibm_module() @:DEALLOCATE(ib_markers%sf) @@ -1038,6 +1037,7 @@ contains @:DEALLOCATE(airfoil_grid_l) end if end subroutine s_finalize_ibm_module + !> Computes the center of mass for IB patch types where we are unable to determine their center of mass analytically. !> These patches include things like NACA airfoils and STL models subroutine s_compute_centroid_offset(ib_marker) @@ -1079,18 +1079,19 @@ contains ! assign the centroid offset as a vector pointing from the true COM to the "centroid" in the input file and replace the ! current centroid patch_ib(ib_marker)%centroid_offset = [patch_ib(ib_marker)%x_centroid, patch_ib(ib_marker)%y_centroid, & - & patch_ib(ib_marker)%z_centroid] - center_of_mass + & patch_ib(ib_marker)%z_centroid] - center_of_mass patch_ib(ib_marker)%x_centroid = center_of_mass(1) patch_ib(ib_marker)%y_centroid = center_of_mass(2) patch_ib(ib_marker)%z_centroid = center_of_mass(3) ! rotate the centroid offset back into the local coords of the IB patch_ib(ib_marker)%centroid_offset = matmul(patch_ib(ib_marker)%rotation_matrix_inverse, & - & patch_ib(ib_marker)%centroid_offset) + & patch_ib(ib_marker)%centroid_offset) else patch_ib(ib_marker)%centroid_offset(:) = [0._wp, 0._wp, 0._wp] end if end subroutine s_compute_centroid_offset + !> Computes the moment of inertia for an immersed boundary !! @param ib_marker Immersed boundary marker index subroutine s_compute_moment_of_inertia(ib_marker, axis) @@ -1115,17 +1116,17 @@ contains patch_ib(ib_marker)%moment = 0.5_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%radius)**2 else if (patch_ib(ib_marker)%geometry == 3) then ! rectangle patch_ib(ib_marker)%moment = patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker) & - & %length_y**2)/6._wp + & %length_y**2)/6._wp else if (patch_ib(ib_marker)%geometry == 6) then ! ellipse patch_ib(ib_marker)%moment = 0.0625_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker) & - & %length_y**2) + & %length_y**2) else if (patch_ib(ib_marker)%geometry == 8) then ! sphere patch_ib(ib_marker)%moment = 0.4*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%radius)**2 else ! we do not have an analytic moment of inertia calculation and need to approximate it directly via a sum count = 0 moment = 0._wp cell_volume = (x_cc(1) - x_cc(0))*(y_cc(1) - y_cc(0)) & - & ! computed without grid stretching. Update in the loop to perform with stretching + & ! computed without grid stretching. Update in the loop to perform with stretching if (p /= 0) then cell_volume = cell_volume*(z_cc(1) - z_cc(0)) end if @@ -1142,10 +1143,10 @@ contains ! get the position in local coordinates so that the axis passes through 0, 0, 0 if (p == 0) then position = [x_cc(i), y_cc(j), 0._wp] - [patch_ib(ib_marker)%x_centroid, & - & patch_ib(ib_marker)%y_centroid, 0._wp] + & patch_ib(ib_marker)%y_centroid, 0._wp] else position = [x_cc(i), y_cc(j), z_cc(k)] - [patch_ib(ib_marker)%x_centroid, & - & patch_ib(ib_marker)%y_centroid, patch_ib(ib_marker)%z_centroid] + & patch_ib(ib_marker)%y_centroid, patch_ib(ib_marker)%z_centroid] end if ! project the position along the axis to find the closest distance to the rotation axis @@ -1167,6 +1168,7 @@ contains $:GPU_UPDATE(device='[patch_ib(ib_marker)%moment]') end if end subroutine s_compute_moment_of_inertia + !> @brief Checks for periodic boundary conditions in all directions, and if so, moves patch location if it left the domain subroutine s_wrap_periodic_ibs() integer :: patch_id @@ -1180,11 +1182,11 @@ contains if (patch_ib(patch_id)%${X}$_centroid < ${X}$_domain%beg) then ! if the boundary exited "left", wrap it back around to the "right" patch_ib(patch_id)%${X}$_centroid = patch_ib(patch_id)%${X}$_centroid + (${X}$_domain%end & - & - ${X}$_domain%beg) + & - ${X}$_domain%beg) else if (patch_ib(patch_id)%${X}$_centroid > ${X}$_domain%end) then ! if the boundary exited "right", wrap it back around to the "left" patch_ib(patch_id)%${X}$_centroid = patch_ib(patch_id)%${X}$_centroid - (${X}$_domain%end & - & - ${X}$_domain%beg) + & - ${X}$_domain%beg) end if end if #:endfor @@ -1204,6 +1206,7 @@ contains end if end do end subroutine s_wrap_periodic_ibs + !> @brief Computes the cross product c = a x b of two 3D vectors. subroutine s_cross_product(a, b, c) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index 6aa1dd6835..c1aeca4ea9 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -8,15 +8,10 @@ !> @brief Iterative ghost rasterization (IGR) for sharp immersed boundary treatment module m_igr use m_derived_types !< Definitions of the derived types - use m_global_parameters - use m_variables_conversion - use m_mpi_proxy - use m_helper - use m_boundary_common implicit none @@ -139,7 +134,7 @@ contains allocate (jac_old_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => jac_old_host(:,:,:) + & idwbuff(3)%beg:idwbuff(3)%end) => jac_old_host(:,:,:) end if end if #endif @@ -207,6 +202,7 @@ contains $:GPU_ENTER_DATA(copyin='[jac_sf(1)%sf]') $:GPU_ENTER_DATA(attach='[jac_sf(1)%sf]') end subroutine s_initialize_igr_module + !> @brief Iteratively solves the implicit gradient reconstruction system using Jacobi or Gauss-Seidel relaxation. subroutine s_igr_iterative_solve(q_cons_vf, bc_type, t_step) #ifdef _CRAYFTN @@ -252,7 +248,7 @@ contains end do fd_coeff = 1._wp/fd_coeff + alf_igr*((1._wp/dx(j)**2._wp)*(1._wp/rho_lx + 1._wp/rho_rx) + (1._wp/dy(k) & - & **2._wp)*(1._wp/rho_ly + 1._wp/rho_ry)) + & **2._wp)*(1._wp/rho_ly + 1._wp/rho_ry)) if (num_dims == 3) then fd_coeff = fd_coeff + alf_igr*(1._wp/dz(l)**2._wp)*(1._wp/rho_lz + 1._wp/rho_rz) @@ -305,6 +301,7 @@ contains end if end do end subroutine s_igr_iterative_solve + !> @brief Computes the IGR viscous stress contribution in the x-direction and accumulates it into the RHS. subroutine s_igr_sigma_x(q_cons_vf, rhs_vf) #ifdef _CRAYFTN @@ -367,21 +364,22 @@ contains #:for LR in ['L', 'R'] $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) + & l) + real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) + & l) + real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j)), & - & kind=stp) + & kind=stp) #:endfor end do end do end do $:END_GPU_PARALLEL_LOOP() end subroutine s_igr_sigma_x + !> @brief Evaluates the approximate Riemann solver for the IGR scheme along a given coordinate direction. subroutine s_igr_riemann_solver(q_cons_vf, rhs_vf, idir) #ifdef _CRAYFTN @@ -440,9 +438,9 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(1._wp*q_cons_vf(momxb)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - 1._wp*q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - 1._wp*q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -472,9 +470,9 @@ contains end do dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j + q, k + 1, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j + q, k + 1, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -494,7 +492,7 @@ contains if (q == 0) then jac_rhs(j, k, l) = real(alf_igr*(2._wp*(dvel(1, 2)*dvel(2, 1)) + dvel(1, & - & 1)**2._wp + dvel(2, 2)**2._wp + (dvel(1, 1) + dvel(2, 2))**2._wp), kind=stp) + & 1)**2._wp + dvel(2, 2)**2._wp + (dvel(1, 1) + dvel(2, 2))**2._wp), kind=stp) end if end do @@ -597,59 +595,59 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -665,18 +663,18 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & - & vel_R, pres_L, pres_R, cfl) + & vel_R, pres_L, pres_R, cfl) do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then @@ -684,67 +682,67 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & - & l)*vel_L(1)*(1._wp/dx(j + 1))), kind=stp) + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_L(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(alpha_L(i) & + & )*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & - & l)*vel_L(1)*(1._wp/dx(j))), kind=stp) + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j))), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & + & *(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j))), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then @@ -752,55 +750,55 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & - & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(alpha_R(i) & + & )*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & - & l)*vel_R(1)*(1._wp/dx(j))), kind=stp) + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(1)*(1._wp/dx(j))), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & + & *(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j))), kind=stp) end do end do end do @@ -838,11 +836,11 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 2)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -874,9 +872,9 @@ contains end do dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j + q, k + 1, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j + q, k + 1, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) if (q == 0) dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j + q, k + 1, & & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j + q, k - 1, l)/rho_sf_small(-1)) if (q == 0) then @@ -907,11 +905,11 @@ contains end do dvel_small(1) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb)%sf(j + q, k, & - & l + 1)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k, l - 1)/rho_sf_small(-1)) + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k, l - 1)/rho_sf_small(-1)) if (q == 0) dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j + q, k, & & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k, l - 1)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j + q, k, & - & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j + q, k, l - 1)/rho_sf_small(-1)) + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j + q, k, l - 1)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -930,8 +928,8 @@ contains if (q == 0) then jac_rhs(j, k, l) = real(alf_igr*(2._wp*(dvel(1, 2)*dvel(2, 1) + dvel(1, 3)*dvel(3, & - & 1) + dvel(2, 3)*dvel(3, 2)) + dvel(1, 1)**2._wp + dvel(2, 2)**2._wp + dvel(3, & - & 3)**2._wp + (dvel(1, 1) + dvel(2, 2) + dvel(3, 3))**2._wp), kind=stp) + & 1) + dvel(2, 3)*dvel(3, 2)) + dvel(1, 1)**2._wp + dvel(2, 2)**2._wp + dvel(3, & + & 3)**2._wp + (dvel(1, 1) + dvel(2, 2) + dvel(3, 3))**2._wp), kind=stp) end if end do @@ -1035,87 +1033,87 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -1131,19 +1129,19 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & - & vel_R, pres_L, pres_R, cfl) + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then @@ -1151,77 +1149,77 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & - & l)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(alpha_L(i)) & + & *(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & + & *(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(rho_L*vel_L(3)) & + & *(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j))), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then @@ -1229,65 +1227,65 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & - & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(alpha_R(i) & + & )*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & - & l)*vel_R(1)*(1._wp/dx(j))), kind=stp) + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(1)*(1._wp/dx(j))), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & + & *(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(rho_R*vel_R(3)) & + & *(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j))), kind=stp) end do end do end do @@ -1328,9 +1326,9 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1, k + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(2)) @@ -1353,9 +1351,9 @@ contains end do dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) @@ -1468,59 +1466,59 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -1539,19 +1537,19 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & - & vel_R, pres_L, pres_R, cfl) + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then @@ -1559,66 +1557,66 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & - & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(alpha_L(i)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1) & - & )*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dy(k)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then @@ -1626,49 +1624,49 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & - & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(alpha_R(i)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1) & - & )*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dy(k)), kind=stp) end do end do end do @@ -1707,9 +1705,9 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1, k + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(2)) @@ -1732,11 +1730,11 @@ contains end do dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) @@ -1761,11 +1759,9 @@ contains end do dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j, k + q, & - & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k + q, & - & l - 1)/rho_sf_small(-1)) + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k + q, l - 1)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j, k + q, & - & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k + q, & - & l - 1)/rho_sf_small(-1)) + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k + q, l - 1)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(2)) vflux_L_arr(3) = vflux_L_arr(3) + coeff_L(q)*(-2._wp*dvel_small(3))/3._wp @@ -1877,87 +1873,87 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -1976,19 +1972,19 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & - & vel_R, pres_L, pres_R, cfl) + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then @@ -1996,77 +1992,77 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & - & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(alpha_L(i)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1) & - & )*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(3) & - & )*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(3)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dy(k)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then @@ -2074,65 +2070,65 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & - & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(alpha_R(i)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1) & - & )*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(3) & - & )*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(3)) & + & *(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dy(k)), kind=stp) end do end do end do @@ -2172,9 +2168,9 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k, & - & l + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k, l + q)/rho_sf_small(-1)) + & l + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k, l + q)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 2)%sf(j + 1, k, & - & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1, k, l + q)/rho_sf_small(-1)) + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1, k, l + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(3)) @@ -2197,9 +2193,9 @@ contains end do dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1, & - & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1, l + q)/rho_sf_small(-1)) + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1, l + q)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j, k + 1, & - & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1, l + q)/rho_sf_small(-1)) + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1, l + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(3)) @@ -2221,13 +2217,11 @@ contains rho_sf_small(i) = rho_L end do dvel_small(1) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb)%sf(j, k, & - & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j, k, & - & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k, & - & l - 1 + q)/rho_sf_small(-1)) + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j, k, & - & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k, & - & l - 1 + q)/rho_sf_small(-1)) + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(2)) @@ -2342,87 +2336,87 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -2441,19 +2435,19 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, vel_R, & - & pres_L, pres_R, cfl) + & pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l + 1) = rhs_vf(i)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(alpha_rho_L(i)) & + & *(1._wp/dz(l)), kind=stp) end do if (num_fluids > 1) then @@ -2461,77 +2455,76 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & - & l + 1)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l + 1)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(alpha_L(i)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(alpha_L(i)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(3)*(1._wp/dz(l)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(3)*(1._wp/dz(l)), kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dz(l)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l + 1) = rhs_vf(i)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(alpha_rho_R(i)) & + & *(1._wp/dz(l)), kind=stp) end do if (num_fluids > 1) then @@ -2539,65 +2532,64 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & - & l + 1)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l + 1)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(alpha_R(i)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(alpha_R(i)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(3)*(1._wp/dz(l)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(3)*(1._wp/dz(l)), kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dz(l)), kind=stp) end do end do end do @@ -2605,6 +2597,7 @@ contains #:endif end if end subroutine s_igr_riemann_solver + !> @brief Computes pressure and maximum wavespeed from left and right reconstructed states for the IGR Riemann solver. subroutine s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, vel_R, pres_L, pres_R, cfl) $:GPU_ROUTINE(parallelism='[seq]') @@ -2642,10 +2635,11 @@ contains a_R = sqrt((pres_R*(1._wp/gamma_R + 1._wp) + pi_inf_R/gamma_R)/rho_R) cfl = max(sqrt(vel_L(1)**2._wp + vel_L(2)**2._wp + vel_L(3)**2._wp), & - & sqrt(vel_R(1)**2._wp + vel_R(2)**2._wp + vel_R(3)**2._wp)) + max(a_L, a_R) + & sqrt(vel_R(1)**2._wp + vel_R(2)**2._wp + vel_R(3)**2._wp)) + max(a_L, a_R) #:endif end if end subroutine s_get_derived_states + !> @brief Accumulates the IGR numerical flux divergence into the right-hand side along the specified coordinate direction. subroutine s_igr_flux_add(q_cons_vf, rhs_vf, flux_vf, idir) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, flux_vf, rhs_vf @@ -2670,7 +2664,7 @@ contains do k = 0, n do j = 0, m rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_vf(i)%sf(j, k - 1, & - & l) - flux_vf(i)%sf(j, k, l)) + & l) - flux_vf(i)%sf(j, k, l)) end do end do end do @@ -2683,7 +2677,7 @@ contains do k = 0, n do j = 0, m rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_vf(i)%sf(j, k, & - & l - 1) - flux_vf(i)%sf(j, k, l)) + & l - 1) - flux_vf(i)%sf(j, k, l)) end do end do end do @@ -2691,6 +2685,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_igr_flux_add + !> @brief Deallocates all arrays and GPU resources allocated by the IGR module. subroutine s_finalize_igr_module() if (viscous) then diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index 29ca383e4f..7c00630aae 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -12,17 +12,11 @@ module m_mpi_proxy #endif use m_helper_basic !< Functions to compare floating point numbers - use m_helper - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_common - use m_nvtx - use ieee_arithmetic implicit none @@ -48,7 +42,7 @@ contains if (n > 0) then if (p > 0) then i_halo_size = -1 + buff_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)*(p + 2*buff_size + 1) & - & /(cells_bounds%mnp_min + 2*buff_size + 1) + & /(cells_bounds%mnp_min + 2*buff_size + 1) else i_halo_size = -1 + buff_size*(cells_bounds%mn_max + 2*buff_size + 1) end if @@ -61,6 +55,7 @@ contains end if #endif end subroutine s_initialize_mpi_proxy_module + !> Since only the processor with rank 0 reads and verifies the consistency of user inputs, these are initially not available to !! the other processors. Then, the purpose of this subroutine is to distribute the user inputs to the remaining processors in !! the communicator. @@ -243,6 +238,7 @@ contains call MPI_BCAST(nv_uvm_pref_gpu, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_bcast_user_inputs + !> @brief Broadcasts random phase numbers from rank 0 to all MPI processes. impure subroutine s_mpi_send_random_number(phi_rn, num_freq) integer, intent(in) :: num_freq @@ -253,6 +249,7 @@ contains call MPI_BCAST(phi_rn, num_freq, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif end subroutine s_mpi_send_random_number + !> @brief Deallocates immersed boundary MPI communication buffers. subroutine s_finalize_mpi_proxy_module() #ifdef MFC_MPI diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index 82f14d2d19..3f8173104a 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -7,9 +7,7 @@ !> @brief MUSCL reconstruction with interface sharpening for contact-preserving advection module m_muscl use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion !< State variables type conversion procedures #ifdef MFC_OpenACC @@ -17,7 +15,6 @@ module m_muscl #endif use m_mpi_proxy - use m_helper private; public :: s_initialize_muscl_module, s_muscl, s_finalize_muscl_module, s_interface_compression @@ -85,13 +82,14 @@ contains @:ALLOCATE(v_rs_ws_z_muscl(is3_muscl%beg:is3_muscl%end, is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, 1:sys_size)) end subroutine s_initialize_muscl_module + !> @brief Performs MUSCL reconstruction of left and right cell-boundary values from cell-averaged variables. subroutine s_muscl(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, is1_muscl_d, & - & is2_muscl_d, is3_muscl_d) + & is2_muscl_d, is3_muscl_d) type(scalar_field), dimension(1:), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & - & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z integer, intent(in) :: muscl_dir type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d integer :: j, k, l, i @@ -185,7 +183,7 @@ contains else if (muscl_lim == 5) then ! SUPERBEE if (slopeL*slopeR > 1e-6_wp) then slope = -1._wp*min(-min(2._wp*abs(slopeL), abs(slopeR)), -min(abs(slopeL), & - & 2._wp*abs(slopeR))) + & 2._wp*abs(slopeR))) end if end if @@ -205,15 +203,16 @@ contains if (int_comp) then call s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, & - & is1_muscl_d, is2_muscl_d, is3_muscl_d) + & is1_muscl_d, is2_muscl_d, is3_muscl_d) end if end subroutine s_muscl + !> @brief Applies THINC interface-compression to sharpen volume-fraction reconstructions at material interfaces. subroutine s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, & - & is1_muscl_d, is2_muscl_d, is3_muscl_d) + & is1_muscl_d, is2_muscl_d, is3_muscl_d) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & - & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z integer, intent(in) :: muscl_dir type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d integer :: j, k, l @@ -251,9 +250,9 @@ contains if (aTHINC < ic_eps) aTHINC = ic_eps if (aTHINC > 1 - ic_eps) aTHINC = 1 - ic_eps vL_rs_vf_${XYZ}$ (j, k, l, contxb) = vL_rs_vf_${XYZ}$ (j, k, l, contxb)/vL_rs_vf_${XYZ}$ (j, k, & - & l, advxb)*aTHINC + & l, advxb)*aTHINC vL_rs_vf_${XYZ}$ (j, k, l, contxe) = vL_rs_vf_${XYZ}$ (j, k, l, & - & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) + & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) vL_rs_vf_${XYZ}$ (j, k, l, advxb) = aTHINC vL_rs_vf_${XYZ}$ (j, k, l, advxe) = 1 - aTHINC @@ -262,9 +261,9 @@ contains if (aTHINC < ic_eps) aTHINC = ic_eps if (aTHINC > 1 - ic_eps) aTHINC = 1 - ic_eps vR_rs_vf_${XYZ}$ (j, k, l, contxb) = vL_rs_vf_${XYZ}$ (j, k, l, contxb)/vL_rs_vf_${XYZ}$ (j, k, & - & l, advxb)*aTHINC + & l, advxb)*aTHINC vR_rs_vf_${XYZ}$ (j, k, l, contxe) = vL_rs_vf_${XYZ}$ (j, k, l, & - & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) + & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) vR_rs_vf_${XYZ}$ (j, k, l, advxb) = aTHINC vR_rs_vf_${XYZ}$ (j, k, l, advxe) = 1 - aTHINC end if @@ -275,6 +274,7 @@ contains end if #:endfor end subroutine s_interface_compression + !> @brief Reshapes cell-averaged variable data into direction-local work arrays for MUSCL reconstruction. subroutine s_initialize_muscl(v_vf, muscl_dir) type(scalar_field), dimension(:), intent(in) :: v_vf @@ -336,6 +336,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_initialize_muscl + !> @brief Deallocates the MUSCL direction-local work arrays. subroutine s_finalize_muscl_module() @:DEALLOCATE(v_rs_ws_x_muscl) diff --git a/src/simulation/m_pressure_relaxation.fpp b/src/simulation/m_pressure_relaxation.fpp index 1dfb597340..8471352bb7 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -34,12 +34,14 @@ contains $:GPU_UPDATE(device='[Res_pr, Re_idx, Re_size]') end if end subroutine s_initialize_pressure_relaxation_module + !> Finalize the pressure relaxation module impure subroutine s_finalize_pressure_relaxation_module if (viscous) then @:DEALLOCATE(Res_pr) end if end subroutine s_finalize_pressure_relaxation_module + !> The main pressure relaxation procedure !! @param q_cons_vf Cell-average conservative variables subroutine s_pressure_relaxation_procedure(q_cons_vf) @@ -56,6 +58,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_pressure_relaxation_procedure + !> Process pressure relaxation for a single cell subroutine s_relax_cell_pressure(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') @@ -74,6 +77,7 @@ contains ! Internal energy correction call s_correct_internal_energies(q_cons_vf, j, k, l) end subroutine s_relax_cell_pressure + !> Check if pressure relaxation is needed for this cell logical function s_needs_pressure_relaxation(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') @@ -90,6 +94,7 @@ contains end if end do end function s_needs_pressure_relaxation + !> Correct volume fractions to physical bounds subroutine s_correct_volume_fractions(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') @@ -116,6 +121,7 @@ contains q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, l)/sum_alpha end do end subroutine s_correct_volume_fractions + !> Main pressure equilibration using Newton-Raphson subroutine s_equilibrate_pressure(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') @@ -167,7 +173,7 @@ contains do i = 1, num_fluids if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then rho_K_s(i) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/max(q_cons_vf(i + advxb - 1)%sf(j, k, l), & - & sgm_eps)*((pres_relax + ps_inf(i))/(pres_K_init(i) + ps_inf(i)))**(1._wp/gs_min(i)) + & sgm_eps)*((pres_relax + ps_inf(i))/(pres_K_init(i) + ps_inf(i)))**(1._wp/gs_min(i)) f_pres = f_pres + q_cons_vf(i + contxb - 1)%sf(j, k, l)/rho_K_s(i) df_pres = df_pres - q_cons_vf(i + contxb - 1)%sf(j, k, l)/(gs_min(i)*rho_K_s(i)*(pres_relax + ps_inf(i))) end if @@ -182,6 +188,7 @@ contains & l) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/rho_K_s(i) end do end subroutine s_equilibrate_pressure + !> Correct internal energies using equilibrated pressure subroutine s_correct_internal_energies(q_cons_vf, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index 07b1807a4b..d47298296e 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -8,15 +8,10 @@ !> @brief Quadrature-based moment methods (QBMM) for polydisperse bubble moment inversion and transport module m_qbmm use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers - use m_helper implicit none @@ -401,6 +396,7 @@ contains end do $:GPU_UPDATE(device='[bubmoms]') end subroutine s_initialize_qbmm_module + !> @brief Computes the QBMM right-hand side source terms for bubble moment transport equations. subroutine s_compute_qbmm_rhs(idir, q_cons_vf, q_prim_vf, rhs_vf, flux_n_vf, pb, rhs_pb) integer, intent(in) :: idir @@ -409,7 +405,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: flux_n_vf real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & - & intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. + & intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. integer :: i, j, k, l, q real(wp) :: nb_q, nb_dot, R, R2, nR, nR2, nR_dot, nR2_dot, var, AX @@ -446,108 +442,108 @@ contains select case (idir) case (1) nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j - 1, k, & - & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j - 1, k, & - & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j - 1, k, & - & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dx(j)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) case (2) nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k - 1, & - & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k - 1, & - & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k - 1, & - & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dy(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) case (3) if (is_axisym) then nb_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, & - & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l)) + & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l)) nR_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, & - & k, l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)) + & k, l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)) nR2_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, & - & k, l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)) + & k, l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, & - & q, i)) + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, & + & i)) else nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, & - & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, & - & l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + & l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, & - & l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + & l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) end if end select if (q <= 2) then select case (idir) case (1) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & - & - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (2) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & - & - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (3) if (is_axisym) then rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & - & - nR2*nb_dot)*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & + & - nR2*nb_dot)*(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & - & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & - & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end select else select case (idir) case (1) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & - & - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (2) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & - & - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (3) if (is_axisym) then rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & - & - nR2*nb_dot)*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & + & - nR2*nb_dot)*(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & - & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & - & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end select end if @@ -583,6 +579,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_compute_qbmm_rhs + !> @brief Builds the coefficient array for the non-polytropic bubble model. subroutine s_coeff_nonpoly(pres, rho, c, coeffs) $:GPU_ROUTINE(function_name='s_coeff_nonpoly',parallelism='[seq]', cray_inline=True) @@ -659,6 +656,7 @@ contains end if end do; end do end subroutine s_coeff_nonpoly + !> @brief Builds the coefficient array for the polytropic bubble model. subroutine s_coeff(pres, rho, c, coeffs) $:GPU_ROUTINE(function_name='s_coeff',parallelism='[seq]', cray_inline=True) @@ -725,6 +723,7 @@ contains end if end do; end do end subroutine s_coeff + !> @brief Performs moment inversion to recover quadrature weights and abscissas and evaluates bubble source terms. subroutine s_mom_inv(q_cons_vf, q_prim_vf, momsp, moms3d, pb, rhs_pb, mv, rhs_mv, ix, iy, iz) type(scalar_field), dimension(:), intent(inout) :: q_cons_vf, q_prim_vf @@ -795,15 +794,14 @@ contains chi_vw = 1._wp/(1._wp + R_v/R_g*(pb(id1, id2, id3, j, q)/pv - 1._wp)) x_vw = M_g*chi_vw/(M_v + (M_g - M_v)*chi_vw) k_mw = x_vw*k_v(q)/(x_vw + (1._wp - x_vw)*phi_vg) + (1._wp - x_vw)*k_g(q)/(x_vw*phi_gv & - & + 1._wp - x_vw) + & + 1._wp - x_vw) rho_mw = pv/(chi_vw*R_v*Tw) rhs_mv(id1, id2, id3, j, q) = -Re_trans_c(q)*((mv(id1, id2, id3, j, q)/(mv(id1, id2, id3, j, & - & q) + mass_g0(q))) - chi_vw) + & q) + mass_g0(q))) - chi_vw) rhs_mv(id1, id2, id3, j, q) = rho_mw*rhs_mv(id1, id2, id3, j, & - & q)/Pe_c/(1._wp - chi_vw)/abscX(j, q) + & q)/Pe_c/(1._wp - chi_vw)/abscX(j, q) grad_T = -Re_trans_T(q)*((pb(id1, id2, id3, j, q)/pb0(q))*(abscX(j, & - & q)/R0(q))**3*(mass_g0(q) + mass_v0(q))/(mass_g0(q) + mv(id1, id2, id3, & - & j, q)) - 1._wp) + & q)/R0(q))**3*(mass_g0(q) + mass_v0(q))/(mass_g0(q) + mv(id1, id2, id3, j, q)) - 1._wp) ht(j, q) = pb0(q)*k_mw*grad_T/Pe_T(q)/abscX(j, q) wght_pb(j, q) = wght(j, q)*(pb(id1, id2, id3, j, q)) wght_mv(j, q) = wght(j, q)*(rhs_mv(id1, id2, id3, j, q)) @@ -825,31 +823,31 @@ contains case (3) if (j == 3) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, & - & q), momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, & + & j, q)) else momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), & - & momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), momrhs(:, i1, i2, j, & + & q)) end if case (2) if ((j >= 7 .and. j <= 9) .or. (j >= 22 .and. j <= 23) & & .or. (j >= 10 .and. j <= 11) .or. (j == 26)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, & - & q), momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, & + & j, q)) else if ((j >= 27 .and. j <= 29) .and. (.not. polytropic)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, & - & q), momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, q), momrhs(:, i1, i2, & + & j, q)) else if ((j >= 30 .and. j <= 32) .and. (.not. polytropic)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, & - & q), momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, q), momrhs(:, i1, i2, & + & j, q)) else momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), & - & momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), momrhs(:, i1, i2, j, & + & q)) end if end select end do @@ -866,12 +864,12 @@ contains do j = 1, nnode drdt = msum(2) drdt2 = merge(-1._wp, 1._wp, j == 1 .or. j == 2)/(2._wp*sqrt(merge(moms(4) - moms(2)**2._wp, & - & sgm_eps, moms(4) - moms(2)**2._wp > 0._wp))) + & sgm_eps, moms(4) - moms(2)**2._wp > 0._wp))) drdt2 = drdt2*(msum(3) - 2._wp*moms(2)*msum(2)) drdt = drdt + drdt2 rhs_pb(id1, id2, id3, j, q) = (-3._wp*gam*drdt/abscX(j, q))*(pb(id1, id2, id3, j, q)) rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3._wp*gam/abscX(j, & - & q))*rhs_mv(id1, id2, id3, j, q)*R_v*Tw + & q))*rhs_mv(id1, id2, id3, j, q)*R_v*Tw rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3._wp*gam/abscX(j, q))*ht(j, q) rhs_mv(id1, id2, id3, j, q) = rhs_mv(id1, id2, id3, j, q)*(4._wp*pi*abscX(j, q)**2._wp) end do @@ -887,13 +885,13 @@ contains else if (polytropic) then momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3._wp*(1._wp - gam), 0._wp, & - & 3._wp*gam) + pv*f_quad(abscX, abscY, wght, 3._wp, 0._wp, & - & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & - & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) + & 3._wp*gam) + pv*f_quad(abscX, abscY, wght, 3._wp, 0._wp, & + & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & + & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) else momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3._wp, 0._wp, & - & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & - & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) + & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & + & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) end if end if else @@ -933,6 +931,7 @@ contains call s_coeff_nonpoly(pres, rho, c, coeff) end if end subroutine s_coeff_selector + !> @brief Performs conditional hyperbolic QMOM (CHyQMOM) inversion for bivariate moments. subroutine s_chyqmom(momin, wght, abscX, abscY) $:GPU_ROUTINE(function_name='s_chyqmom',parallelism='[seq]', cray_inline=True) @@ -989,6 +988,7 @@ contains abscX = bu + [up(1), up(1), up(2), up(2)] abscY = bv + [Vf(1) + vp21, Vf(1) + vp22, Vf(2) + vp21, Vf(2) + vp22] end subroutine s_chyqmom + !> @brief Performs hyperbolic QMOM (HyQMOM) inversion for univariate moments. subroutine s_hyqmom(frho, fup, fmom) $:GPU_ROUTINE(function_name='s_hyqmom',parallelism='[seq]', cray_inline=True) @@ -1006,6 +1006,7 @@ contains fup(1) = bu - sqrt(c2) fup(2) = bu + sqrt(c2) end subroutine s_hyqmom + !> @brief Evaluates a weighted quadrature sum over all bubble size bins and nodes. function f_quad(abscX, abscY, wght_in, q, r, s) $:GPU_ROUTINE(parallelism='[seq]') @@ -1029,6 +1030,7 @@ contains f_quad = f_quad + weight(i)*(R0(i)**s)*f_quad_RV end do end function f_quad + !> @brief Evaluates a weighted 2D quadrature sum over quadrature nodes for a single size bin. function f_quad2D(abscX, abscY, wght_in, pow) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 2bffac426f..9da3a37342 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -9,13 +9,9 @@ !! physical source terms module m_rhs use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_weno !< Weighted and essentially non-oscillatory (WENO) !! schemes for spatial reconstruction of variables @@ -23,39 +19,22 @@ module m_rhs !! schemes for conservation laws use m_riemann_solvers !< Exact and approximate Riemann problem solvers - use m_cbc !< Characteristic boundary conditions (CBC) - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL - use m_qbmm !< Moment inversion - use m_hypoelastic - use m_hyperelastic - use m_acoustic_src - use m_viscous - use m_ibm - use m_nvtx - use m_boundary_common - use m_helper - use m_surface_tension - use m_body_forces - use m_chemistry - use m_igr - use m_pressure_relaxation implicit none @@ -522,9 +501,10 @@ contains @:ALLOCATE(nbub(0:m, 0:n, 0:p)) end if end subroutine s_initialize_rhs_module + !> @brief Computes the right-hand side of the semi-discrete governing equations for a single time stage. impure subroutine s_compute_rhs(q_cons_vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_in, rhs_pb, mv_in, rhs_mv, t_step, & - & time_avg, stage) + & time_avg, stage) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), intent(inout) :: q_T_sf @@ -533,8 +513,8 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & - & intent(inout) & - & :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now + & intent(inout) & + & :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: mv_in real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv integer, intent(in) :: t_step @@ -577,7 +557,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - 1 q_cons_qp%vf(i)%sf(j, k, l) = q_cons_qp%vf(i)%sf(j, k, l)*(1._wp - q_cons_qp%vf(alf_idx)%sf(j, k, & - & l))/alf_sum%sf(j, k, l) + & l))/alf_sum%sf(j, k, l) end do end do end do @@ -617,8 +597,8 @@ contains if ((viscous .and. .not. igr) .or. dummy) then call nvtxStartRange("RHS-VISCOUS") call s_get_viscous(qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, qL_prim, qR_rsx_vf, & - & qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, q_prim_qp, & - & dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, idwbuff(1), idwbuff(2), idwbuff(3)) + & qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, q_prim_qp, dq_prim_dx_qp, & + & dq_prim_dy_qp, dq_prim_dz_qp, idwbuff(1), idwbuff(2), idwbuff(3)) call nvtxEndRange end if @@ -669,41 +649,41 @@ contains ! Reconstruct densitiess iv%beg = 1; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(1:sys_size), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) else iv%beg = 1; iv%end = contxe call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) end if else if (all(Re_size == 0)) then iv%beg = 1; iv%end = E_idx - 1 call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = E_idx call s_reconstruct_cell_boundary_values_first_order(q_prim_qp%vf(E_idx), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx + 1; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) else iv%beg = 1; iv%end = contxe call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = E_idx call s_reconstruct_cell_boundary_values_first_order(q_prim_qp%vf(E_idx), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx + 1; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) end if end if @@ -711,23 +691,18 @@ contains if (weno_Re_flux) then iv%beg = momxb; iv%end = momxe call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dx_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & - & dqR_rsz_vf, id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), & - & dqR_prim_dx_n(id)%vf(iv%beg:iv%end), idwbuff(1), & - & idwbuff(2), idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), & + & dqR_prim_dx_n(id)%vf(iv%beg:iv%end), idwbuff(1), idwbuff(2), idwbuff(3)) if (n > 0) then call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dy_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & - & dqR_rsz_vf, id, dqL_prim_dy_n(id)%vf(iv%beg:iv%end), & - & dqR_prim_dy_n(id)%vf(iv%beg:iv%end), idwbuff(1), & - & idwbuff(2), idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, & + & dqL_prim_dy_n(id)%vf(iv%beg:iv%end), dqR_prim_dy_n(id)%vf(iv%beg:iv%end), idwbuff(1), idwbuff(2), & + & idwbuff(3)) if (p > 0) then call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dz_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & - & dqR_rsz_vf, id, & - & dqL_prim_dz_n(id)%vf(iv%beg:iv%end), & - & dqR_prim_dz_n(id)%vf(iv%beg:iv%end), idwbuff(1), & - & idwbuff(2), idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, & + & dqL_prim_dz_n(id)%vf(iv%beg:iv%end), dqR_prim_dz_n(id)%vf(iv%beg:iv%end), idwbuff(1), & + & idwbuff(2), idwbuff(3)) end if end if end if @@ -750,9 +725,9 @@ contains ! Computing Riemann Solver Flux and Source Flux call nvtxStartRange("RHS-RIEMANN-SOLVER") call s_riemann_solver(qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n(id)%vf, dqR_prim_dy_n(id)%vf, & - & dqR_prim_dz_n(id)%vf, qR_prim(id)%vf, qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & dqL_prim_dx_n(id)%vf, dqL_prim_dy_n(id)%vf, dqL_prim_dz_n(id)%vf, qL_prim(id)%vf, & - & q_prim_qp%vf, flux_n(id)%vf, flux_src_n(id)%vf, flux_gsrc_n(id)%vf, id, irx, iry, irz) + & dqR_prim_dz_n(id)%vf, qR_prim(id)%vf, qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, dqL_prim_dx_n(id)%vf, & + & dqL_prim_dy_n(id)%vf, dqL_prim_dz_n(id)%vf, qL_prim(id)%vf, q_prim_qp%vf, flux_n(id)%vf, flux_src_n(id)%vf, & + & flux_gsrc_n(id)%vf, id, irx, iry, irz) call nvtxEndRange !$:GPU_UPDATE(host='[flux_n(1)%vf(1)%sf]') @@ -780,7 +755,7 @@ contains if (viscous .or. surface_tension .or. chem_params%diffusion) then call nvtxStartRange("RHS-ADD-PHYSICS") call s_compute_additional_physics_rhs(id, q_prim_qp%vf, rhs_vf, flux_src_n(id)%vf, dq_prim_dx_qp(1)%vf, & - & dq_prim_dy_qp(1)%vf, dq_prim_dz_qp(1)%vf) + & dq_prim_dy_qp(1)%vf, dq_prim_dz_qp(1)%vf) call nvtxEndRange end if @@ -805,7 +780,7 @@ contains do k = 0, n do j = 0, m rhs_vf(psi_idx)%sf(j, k, l) = rhs_vf(psi_idx)%sf(j, k, l) - q_prim_vf(psi_idx)%sf(j, k, & - & l)/hyper_cleaning_tau + & l)/hyper_cleaning_tau end do end do end do @@ -897,6 +872,7 @@ contains call nvtxEndRange end subroutine s_compute_rhs + !> @brief Accumulates advection source contributions from a given coordinate direction into the RHS. subroutine s_compute_advection_source_term(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf) integer, intent(in) :: idir @@ -916,9 +892,9 @@ contains do l_loop = 0, n do k_loop = 0, m blkmod1(k_loop, l_loop, q_loop) = ((gammas(1) + 1._wp)*q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, & - & q_loop) + pi_infs(1))/gammas(1) + & q_loop) + pi_infs(1))/gammas(1) blkmod2(k_loop, l_loop, q_loop) = ((gammas(2) + 1._wp)*q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, & - & q_loop) + pi_infs(2))/gammas(2) + & q_loop) + pi_infs(2))/gammas(2) alpha1(k_loop, l_loop, q_loop) = q_cons_vf%vf(advxb)%sf(k_loop, l_loop, q_loop) if (bubbles_euler) then @@ -928,9 +904,9 @@ contains end if Kterm(k_loop, l_loop, q_loop) = alpha1(k_loop, l_loop, q_loop)*alpha2(k_loop, l_loop, & - & q_loop)*(blkmod2(k_loop, l_loop, q_loop) - blkmod1(k_loop, l_loop, q_loop))/(alpha1(k_loop, & - & l_loop, q_loop)*blkmod2(k_loop, l_loop, q_loop) + alpha2(k_loop, l_loop, q_loop)*blkmod1(k_loop, & - & l_loop, q_loop)) + & q_loop)*(blkmod2(k_loop, l_loop, q_loop) - blkmod1(k_loop, l_loop, q_loop))/(alpha1(k_loop, l_loop, & + & q_loop)*blkmod2(k_loop, l_loop, q_loop) + alpha2(k_loop, l_loop, q_loop)*blkmod1(k_loop, l_loop, & + & q_loop)) end do end do end do @@ -974,8 +950,8 @@ contains flux_face1 = flux_src_n_vf%vf(advxb)%sf(k_loop, l_loop, q_loop) flux_face2 = flux_src_n_vf%vf(advxb)%sf(k_loop - 1, l_loop, q_loop) rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, & - & q_loop) = rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, & - & q_loop) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + & q_loop) = rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, & + & q_loop) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) end do end do end do @@ -1019,10 +995,10 @@ contains flux_face1 = flux_src_n_vf%vf(advxb)%sf(q, k, l) flux_face2 = flux_src_n_vf%vf(advxb)%sf(q, k - 1, l) rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) = rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, & - & l) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + & l) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) if (cyl_coord) then rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) = rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, & - & l) - 5.e-1_wp/y_cc(k)*advected_qty_val*pressure_val*(flux_face1 + flux_face2) + & l) - 5.e-1_wp/y_cc(k)*advected_qty_val*pressure_val*(flux_face1 + flux_face2) end if end do end do @@ -1114,7 +1090,7 @@ contains flux_face1 = flux_src_n_vf%vf(advxb)%sf(l, q, k) flux_face2 = flux_src_n_vf%vf(advxb)%sf(l, q, k - 1) rhs_vf(i_fluid_loop + intxb - 1)%sf(l, q, k) = rhs_vf(i_fluid_loop + intxb - 1)%sf(l, q, & - & k) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + & k) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) end do end do end do @@ -1128,7 +1104,7 @@ contains !> @brief Adds the advection source flux-difference terms for a single coordinate direction to the RHS. subroutine s_add_directional_advection_source_terms(current_idir, rhs_vf_arg, q_cons_vf_arg, q_prim_vf_arg, & - & flux_src_n_vf_arg, Kterm_arg) + & flux_src_n_vf_arg, Kterm_arg) integer, intent(in) :: current_idir type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf_arg type(vector_field), intent(in) :: q_cons_vf_arg @@ -1156,7 +1132,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx - 1, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(j_adv)%sf(k_idx, l_idx, & - & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1175,7 +1151,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx - 1, l_idx, q_idx) rhs_vf_arg(advxe)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(advxe)%sf(k_idx, l_idx, & - & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do $:END_GPU_PARALLEL_LOOP() @@ -1189,7 +1165,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx - 1, l_idx, q_idx) rhs_vf_arg(advxb)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(advxb)%sf(k_idx, l_idx, & - & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if @@ -1203,14 +1179,14 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx - 1, l_idx, q_idx) rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(j_adv)%sf(k_idx, l_idx, & - & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() end if end if case (2) & - & ! y-direction: loops q_idx (x), k_idx (y), l_idx (z); sf(q_idx, k_idx, l_idx); dy(k_idx); Kterm(q_idx,k_idx,l_idx) + & ! y-direction: loops q_idx (x), k_idx (y), l_idx (z); sf(q_idx, k_idx, l_idx); dy(k_idx); Kterm(q_idx,k_idx,l_idx) use_standard_riemann = (riemann_solver == 1 .or. riemann_solver == 4) if (use_standard_riemann) then $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & @@ -1224,7 +1200,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx - 1, l_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(j_adv)%sf(q_idx, k_idx, & - & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1243,10 +1219,10 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx - 1, l_idx) rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxe)%sf(q_idx, k_idx, & - & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) if (cyl_coord) then rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxe)%sf(q_idx, k_idx, & - & l_idx) - (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) + & l_idx) - (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) end if end do; end do; end do $:END_GPU_PARALLEL_LOOP() @@ -1261,10 +1237,10 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx - 1, l_idx) rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxb)%sf(q_idx, k_idx, & - & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) if (cyl_coord) then rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxb)%sf(q_idx, k_idx, & - & l_idx) + (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) + & l_idx) + (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) end if end do; end do; end do $:END_GPU_PARALLEL_LOOP() @@ -1279,14 +1255,14 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx - 1, l_idx) rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(j_adv)%sf(q_idx, k_idx, & - & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() end if end if case (3) & - & ! z-direction: loops l_idx (x), q_idx (y), k_idx (z); sf(l_idx, q_idx, k_idx); dz(k_idx); Kterm(l_idx,q_idx,k_idx) + & ! z-direction: loops l_idx (x), q_idx (y), k_idx (z); sf(l_idx, q_idx, k_idx); dz(k_idx); Kterm(l_idx,q_idx,k_idx) if (grid_geometry == 3) then use_standard_riemann = (riemann_solver == 1) else @@ -1305,7 +1281,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx - 1) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(j_adv)%sf(l_idx, q_idx, & - & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1324,7 +1300,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx - 1) rhs_vf_arg(advxe)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(advxe)%sf(l_idx, q_idx, & - & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do $:END_GPU_PARALLEL_LOOP() @@ -1338,7 +1314,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx - 1) rhs_vf_arg(advxb)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(advxb)%sf(l_idx, q_idx, & - & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if @@ -1352,7 +1328,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx - 1) rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(j_adv)%sf(l_idx, q_idx, & - & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() @@ -1378,7 +1354,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dx(j)*q_prim_vf(c_idx)%sf(j, k, & - & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j - 1, k, l)) + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j - 1, k, l)) end do end do end do @@ -1394,7 +1370,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)*(flux_src_n_in(i)%sf(j - 1, k, & - & l) - flux_src_n_in(i)%sf(j, k, l)) + & l) - flux_src_n_in(i)%sf(j, k, l)) end do end if @@ -1402,13 +1378,12 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)*(flux_src_n_in(i)%sf(j - 1, k, & - & l) - flux_src_n_in(i)%sf(j, k, l)) + & l) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + 1._wp/dx(j)*(flux_src_n_in(E_idx)%sf(j - 1, k, l) - flux_src_n_in(E_idx)%sf(j, & - & k, l)) + & l) + 1._wp/dx(j)*(flux_src_n_in(E_idx)%sf(j - 1, k, l) - flux_src_n_in(E_idx)%sf(j, k, l)) end if end if end do @@ -1424,7 +1399,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dy(k)*q_prim_vf(c_idx)%sf(j, k, & - & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k - 1, l)) + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k - 1, l)) end do end do end do @@ -1435,14 +1410,12 @@ contains if (viscous .or. dummy) then if (p > 0) then call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & - & idwbuff(1), idwbuff(2), idwbuff(3)) + & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & + & idwbuff(1), idwbuff(2), idwbuff(3)) else call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & - & idwbuff(1), idwbuff(2), idwbuff(3)) + & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & + & idwbuff(1), idwbuff(2), idwbuff(3)) end if $:GPU_PARALLEL_LOOP(private='[i, j, l]', collapse=2) @@ -1451,7 +1424,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, 0, l) = rhs_vf(i)%sf(j, 0, l) + 1._wp/(y_cc(1) - y_cc(-1))*(tau_Re_vf(i)%sf(j, & - & -1, l) - tau_Re_vf(i)%sf(j, 1, l)) + & -1, l) - tau_Re_vf(i)%sf(j, 1, l)) end do end do end do @@ -1465,7 +1438,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, k - 1, & - & l) - flux_src_n_in(i)%sf(j, k, l)) + & l) - flux_src_n_in(i)%sf(j, k, l)) end do end do end do @@ -1482,7 +1455,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, & - & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) + & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) end do end if @@ -1490,12 +1463,12 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, & - & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) + & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + 1._wp/dy(k)*(flux_src_n_in(E_idx)%sf(j, k - 1, & - & l) - flux_src_n_in(E_idx)%sf(j, k, l)) + & l) + 1._wp/dy(k)*(flux_src_n_in(E_idx)%sf(j, k - 1, l) - flux_src_n_in(E_idx)%sf(j, & + & k, l)) end if end if end do @@ -1516,7 +1489,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - 5.e-1_wp/y_cc(k)*(flux_src_n_in(i)%sf(j, & - & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) + & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) end do end do end do @@ -1544,7 +1517,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - 5.e-1_wp/y_cc(k)*(flux_src_n_in(i)%sf(j, & - & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) + & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) end do end do end do @@ -1560,7 +1533,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dz(l)*q_prim_vf(c_idx)%sf(j, k, & - & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k, l - 1)) + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k, l - 1)) end do end do end do @@ -1576,7 +1549,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_src_n_in(i)%sf(j, k, & - & l - 1) - flux_src_n_in(i)%sf(j, k, l)) + & l - 1) - flux_src_n_in(i)%sf(j, k, l)) end do end if @@ -1584,12 +1557,11 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_src_n_in(i)%sf(j, k, & - & l - 1) - flux_src_n_in(i)%sf(j, k, l)) + & l - 1) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + 1._wp/dz(l)*(flux_src_n_in(E_idx)%sf(j, k, l - 1) - flux_src_n_in(E_idx)%sf(j, & - & k, l)) + & l) + 1._wp/dz(l)*(flux_src_n_in(E_idx)%sf(j, k, l - 1) - flux_src_n_in(E_idx)%sf(j, k, l)) end if end if end do @@ -1604,10 +1576,10 @@ contains do k = 0, n do j = 0, m rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + 5.e-1_wp*(flux_src_n_in(momxe)%sf(j, & - & k, l - 1) + flux_src_n_in(momxe)%sf(j, k, l)) + & k, l - 1) + flux_src_n_in(momxe)%sf(j, k, l)) rhs_vf(momxe)%sf(j, k, l) = rhs_vf(momxe)%sf(j, k, l) - 5.e-1_wp*(flux_src_n_in(momxb + 1)%sf(j, k, & - & l - 1) + flux_src_n_in(momxb + 1)%sf(j, k, l)) + & l - 1) + flux_src_n_in(momxb + 1)%sf(j, k, l)) end do end do end do @@ -1653,17 +1625,16 @@ contains if (n > 0) then if (p > 0) then call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & - & :, iv%beg:iv%end), recon_dir, is1, is2, is3) + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:, & + & iv%beg:iv%end), recon_dir, is1, is2, is3) else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & - & recon_dir, is1, is2, is3) + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, is1, is2, is3) end if else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & - & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1, is2, is3) + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1, is2, is3) end if end if #:endfor diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 3e4e0f3610..473b5b1dd9 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -10,23 +10,14 @@ module m_riemann_solvers use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_bubbles !< To get the bubble wall pressure function - use m_bubbles_EE - use m_surface_tension !< To get the capillary fluxes - use m_helper_basic !< Functions to compare floating point numbers - 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 @@ -118,15 +109,15 @@ contains !! @param iy Index bounds in the y-dir !! @param iz Index bounds in the z-dir subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & - & qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & + & q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf integer, intent(in) :: norm_dir @@ -135,20 +126,20 @@ contains #:for NAME, NUM in [('hll', 1), ('hllc', 2), ('hlld', 4), ('lf', 5)] if (riemann_solver == ${NUM}$) then call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & - & dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, & - & flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) end if #:endfor end subroutine s_riemann_solver + !> Dispatch to the subroutines that are utilized to compute the viscous source fluxes for either Cartesian or cylindrical !! geometries. For more information please refer to: 1) s_compute_cartesian_viscous_source_flux 2) !! s_compute_cylindrical_viscous_source_flux subroutine s_compute_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, dvelR_dy_vf, & - & dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) + & dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) type(scalar_field), dimension(num_vels), intent(in) :: velL_vf, velR_vf, dvelL_dx_vf, dvelR_dx_vf, dvelL_dy_vf, & - & dvelR_dy_vf, dvelL_dz_vf, dvelR_dz_vf + & dvelR_dy_vf, dvelL_dz_vf, dvelR_dz_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf integer, intent(in) :: norm_dir @@ -156,24 +147,24 @@ contains if (grid_geometry == 3) then call s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & - & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) + & dvelR_dy_vf, dvelR_dz_vf, flux_src_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, norm_dir) + & dvelR_dz_vf, flux_src_vf, norm_dir) end if end subroutine s_compute_viscous_source_flux + !> @brief Computes intercell fluxes using the Harten-Lax-van Leer (HLL) approximate Riemann solver. subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - & dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -227,7 +218,7 @@ contains 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 + 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) @@ -239,9 +230,8 @@ contains ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction call s_initialize_riemann_solver(flux_src_vf, norm_dir) @@ -453,7 +443,7 @@ contains & + pres_mag%R ! includes magnetic energy H_L = (E_L + pres_L - pres_mag%L)/rho_L H_R = (E_R + pres_R - pres_mag%R) & - & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 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 @@ -529,16 +519,16 @@ contains @: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) + & 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) + & 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) + & 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) @@ -561,18 +551,16 @@ contains s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) else if (hypoelasticity) then s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & - & /rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & - & /rho_R)) + & /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)) + & /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)) + & 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)) + & 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) @@ -585,19 +573,19 @@ contains 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)))) + & - 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 == 2) 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 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))))) + & 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))))) + & 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 @@ -608,9 +596,9 @@ contains 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)) + & 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)) + & s_R)) ! Low Mach correction if (low_Mach == 1) then @@ -624,16 +612,15 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i) & - & *vel_L(norm_dir) + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) + & 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, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i) & - & *vel_L(norm_dir) + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i))) & - & /(s_M - s_P) + & 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 @@ -644,10 +631,10 @@ contains ! Flux of rho*v_i in the ${XYZ}$ direction ! = rho * v_i * v_${XYZ}$ - B_i * B_${XYZ}$ + delta_(${XYZ}$,i) * p_tot flux_rs${XYZ}$_vf(j, k, l, & - & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) & - & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & - & - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & - & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) + & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) + dir_flg(i) & + & *(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) - B%L(i)*B%L(norm_dir) & + & + dir_flg(i)*(pres_L + pres_mag%L)) + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M & + & - s_P) end do else if (mhd .and. relativity) then $:GPU_LOOP(parallelism='[seq]') @@ -655,40 +642,38 @@ contains ! Flux of m_i in the ${XYZ}$ direction ! = m_i * v_${XYZ}$ - b_i/Gamma * B_${XYZ}$ + delta_(${XYZ}$,i) * p_tot flux_rs${XYZ}$_vf(j, k, l, & - & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) & - & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) & - & - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & - & + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) + & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) + dir_flg(i) & + & *(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) - b4%L(i)/Ga%L*B%L(norm_dir) & + & + dir_flg(i)*(pres_L + pres_mag%L)) + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) end do else if (bubbles_euler) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & - & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L) & + & *(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do else if (hypoelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & - & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & - & *pres_L - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L - tau_e_L(dir_idx_tau(i))) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) end do else $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & - & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_L) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) & + & - vel_L(dir_idx(i))) end do end if @@ -697,24 +682,22 @@ contains ! 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_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & - & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - & - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir) & - & *(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) + s_M*s_P*(E_L & - & - E_R))/(s_M - s_P) + & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1) & + & *B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) - s_P*(vel_L(norm_dir)*(E_L + pres_L & + & + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + & + s_M*s_P*(E_L - E_R))/(s_M - s_P) #:endif else if (mhd .and. relativity) then ! energy flux = m_${XYZ}$ - mass flux ! Hard-coded for single-component for now flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L & - & - E_R))/(s_M - s_P) + & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) - s_P*(cm%L(norm_dir) & + & - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L - E_R))/(s_M - s_P) else if (bubbles_euler) then flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - & - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M & - & - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) - s_P*vel_L(dir_idx(1))*(E_L & + & + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then flux_tau_L = 0._wp; flux_tau_R = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -723,23 +706,20 @@ contains flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) end do flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R)) & - & /(s_M - s_P) + & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) - s_P*(vel_L(dir_idx(1))*(E_L & + & + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) else flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & - & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*(vel_R_rms - vel_L_rms)/2._wp + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & + & + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp end if ! Elastic Stresses if (hypoelasticity) then do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow flux_rs${XYZ}$_vf(j, k, l, & - & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & - & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & - & - rho_R*tau_e_R(i)))/(s_M - s_P) + & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) - s_P*(rho_L*vel_L(dir_idx(1) & + & )*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) - rho_R*tau_e_R(i)))/(s_M - s_P) end do end if @@ -747,9 +727,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = (qL_prim_rs${XYZ}$_vf(j, k, l, i) - qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, i))*s_M*s_P/(s_M - s_P) + & k, l, i))*s_M*s_P/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) + & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) end do if (bubbles_euler) then @@ -766,8 +746,8 @@ contains Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) + & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if @@ -779,9 +759,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 0, 1 flux_rsx_vf(j, k, l, & - & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & - & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & - & - B%R(2 + i)))/(s_M - s_P) + & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) - s_P*(vel_L(1) & + & *B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) end do else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) @@ -790,25 +769,25 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 0, 2 flux_rs${XYZ}$_vf(j, k, l, & - & B_idx%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) + & B_idx%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_rs${XYZ}$_vf(j, k, l, B_idx%beg + norm_dir - 1) = flux_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + norm_dir - 1) + (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & psi_idx) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx))/(s_M - s_P) + & B_idx%beg + norm_dir - 1) + (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & psi_idx) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx))/(s_M - s_P) flux_rs${XYZ}$_vf(j, k, l, & - & psi_idx) = (hyper_cleaning_speed**2*(s_M*B%R(norm_dir) & - & - s_P*B%L(norm_dir)) + s_M*s_P*(qL_prim_rs${XYZ}$_vf(j, k, l, & - & psi_idx) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, psi_idx)))/(s_M - s_P) + & psi_idx) = (hyper_cleaning_speed**2*(s_M*B%R(norm_dir) - s_P*B%L(norm_dir)) & + & + s_M*s_P*(qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx) - qR_prim_rs${XYZ}$_vf(j + 1, k, & + & l, psi_idx)))/(s_M - s_P) else flux_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + norm_dir - 1) & - & = 0._wp ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero + & B_idx%beg + norm_dir - 1) & + & = 0._wp ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero end if end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -823,7 +802,7 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + & contxe + 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 = advxb, advxe @@ -834,7 +813,7 @@ contains if (cyl_coord .and. hypoelasticity) then ! += tau_sigmasigma using HLL flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) + & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) $:GPU_LOOP(parallelism='[seq]') do i = strxb, strxe @@ -852,33 +831,31 @@ contains if (viscous .or. dummy) then if (weno_Re_flux) then call s_compute_viscous_source_flux(qL_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & - & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & - & qR_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & - & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), qR_prim_vf(momxb:momxe), & + & dqR_prim_dx_vf(momxb:momxe), dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) else call s_compute_viscous_source_flux(q_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & - & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & - & q_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & - & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), q_prim_vf(momxb:momxe), & + & dqR_prim_dx_vf(momxb:momxe), dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) end if end if call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) end subroutine s_hll_riemann_solver + !> @brief Computes intercell fluxes using the Lax-Friedrichs (LF) approximate Riemann solver. subroutine s_lf_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - & dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -901,7 +878,7 @@ contains real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 real(wp), dimension(num_dims, num_dims) :: vel_grad_L, & - & vel_grad_R !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + & vel_grad_R !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. #:endif real(wp) :: rho_L, rho_R real(wp) :: pres_L, pres_R @@ -934,22 +911,21 @@ contains 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 + 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. + 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, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction call s_initialize_riemann_solver(flux_src_vf, norm_dir) @@ -1159,7 +1135,7 @@ contains & + pres_mag%R ! includes magnetic energy H_L = (E_L + pres_L - pres_mag%L)/rho_L H_R = (E_R + pres_R - pres_mag%R) & - & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 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 @@ -1200,10 +1176,10 @@ contains 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) + & 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) + & qv_R) if (mhd) then call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) @@ -1239,16 +1215,15 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i) & - & *vel_L(norm_dir) + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) + & 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, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i) & - & *vel_L(norm_dir) + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i))) & - & /(s_M - s_P) + & 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 @@ -1259,10 +1234,10 @@ contains ! Flux of rho*v_i in the ${XYZ}$ direction ! = rho * v_i * v_${XYZ}$ - B_i * B_${XYZ}$ + delta_(${XYZ}$,i) * p_tot flux_rs${XYZ}$_vf(j, k, l, & - & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) & - & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & - & - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & - & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) + & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) + dir_flg(i) & + & *(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) - B%L(i)*B%L(norm_dir) & + & + dir_flg(i)*(pres_L + pres_mag%L)) + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M & + & - s_P) end do else if (mhd .and. relativity) then $:GPU_LOOP(parallelism='[seq]') @@ -1270,40 +1245,38 @@ contains ! Flux of m_i in the ${XYZ}$ direction ! = m_i * v_${XYZ}$ - b_i/Gamma * B_${XYZ}$ + delta_(${XYZ}$,i) * p_tot flux_rs${XYZ}$_vf(j, k, l, & - & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) & - & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) & - & - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & - & + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) + & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) + dir_flg(i) & + & *(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) - b4%L(i)/Ga%L*B%L(norm_dir) & + & + dir_flg(i)*(pres_L + pres_mag%L)) + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) end do else if (bubbles_euler) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & - & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L) & + & *(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do else if (hypoelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & - & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & - & *pres_L - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L - tau_e_L(dir_idx_tau(i))) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) end do else $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & - & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_L) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) & + & - vel_L(dir_idx(i))) end do end if @@ -1312,24 +1285,22 @@ contains ! 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_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & - & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - & - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir) & - & *(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) + s_M*s_P*(E_L & - & - E_R))/(s_M - s_P) + & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1) & + & *B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) - s_P*(vel_L(norm_dir)*(E_L + pres_L & + & + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + & + s_M*s_P*(E_L - E_R))/(s_M - s_P) #:endif else if (mhd .and. relativity) then ! energy flux = m_${XYZ}$ - mass flux ! Hard-coded for single-component for now flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L & - & - E_R))/(s_M - s_P) + & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) - s_P*(cm%L(norm_dir) & + & - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L - E_R))/(s_M - s_P) else if (bubbles_euler) then flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - & - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M & - & - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) - s_P*vel_L(dir_idx(1))*(E_L & + & + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then flux_tau_L = 0._wp; flux_tau_R = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -1338,23 +1309,20 @@ contains flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) end do flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R)) & - & /(s_M - s_P) + & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) - s_P*(vel_L(dir_idx(1))*(E_L & + & + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) else flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & - & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*(vel_R_rms - vel_L_rms)/2._wp + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & + & + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp end if ! Elastic Stresses if (hypoelasticity) then do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow flux_rs${XYZ}$_vf(j, k, l, & - & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & - & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & - & - rho_R*tau_e_R(i)))/(s_M - s_P) + & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) - s_P*(rho_L*vel_L(dir_idx(1) & + & )*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) - rho_R*tau_e_R(i)))/(s_M - s_P) end do end if @@ -1362,9 +1330,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = (qL_prim_rs${XYZ}$_vf(j, k, l, i) - qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, i))*s_M*s_P/(s_M - s_P) + & k, l, i))*s_M*s_P/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) + & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) end do if (bubbles_euler) then @@ -1381,8 +1349,8 @@ contains Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) + & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if @@ -1394,9 +1362,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 0, 1 flux_rsx_vf(j, k, l, & - & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & - & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & - & - B%R(2 + i)))/(s_M - s_P) + & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) - s_P*(vel_L(1) & + & *B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) end do else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) @@ -1405,10 +1372,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 0, 2 flux_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + i) = (1 - dir_flg(i + 1))*(s_M*(vel_R(dir_idx(1))*B%R(i & - & + 1) - vel_R(i + 1)*B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) & - & - vel_L(i + 1)*B%L(norm_dir)) + s_M*s_P*(B%L(i + 1) - B%R(i + 1))) & - & /(s_M - s_P) + & B_idx%beg + i) = (1 - dir_flg(i + 1))*(s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i & + & + 1)*B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir) & + & ) + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) end do end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -1423,7 +1389,7 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + & contxe + 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 = advxb, advxe @@ -1434,7 +1400,7 @@ contains if (cyl_coord .and. hypoelasticity) then ! += tau_sigmasigma using HLL flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) + & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) $:GPU_LOOP(parallelism='[seq]') do i = strxb, strxe @@ -1520,18 +1486,18 @@ contains do i = 1, num_dims vel_grad_L(i, 1) = (dqL_prim_dx_vf(momxb + i - 1)%sf(j, k, l)/Re_L(1)) vel_grad_R(i, 1) = (dqR_prim_dx_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), & - & idx_right_phys(3))/Re_R(1)) + & 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(momxb + i - 1)%sf(j, k, l)/Re_L(1)) vel_grad_R(i, 2) = (dqR_prim_dy_vf(momxb + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(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(momxb + i - 1)%sf(j, k, l)/Re_L(1)) vel_grad_R(i, 3) = (dqR_prim_dz_vf(momxb + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) + & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) end if #:endif #:endif @@ -1539,38 +1505,36 @@ contains if (norm_dir == 1) then flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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)) + & 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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)) + & 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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 @@ -1578,67 +1542,65 @@ contains else if (norm_dir == 2) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%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)) + & 2) + vel_grad_R(1, 2)) - 0.5_wp*(vel_grad_L(2, 1) + vel_grad_R(2, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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)) + & 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%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)) + & 3) + vel_grad_R(1, 3)) - 0.5_wp*(vel_grad_L(3, 1) + vel_grad_R(3, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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)) + & 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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 @@ -1648,41 +1610,41 @@ contains do i = 1, num_dims vel_grad_L(i, 1) = (dqL_prim_dx_vf(momxb + i - 1)%sf(j, k, l)/Re_L(2)) vel_grad_R(i, 1) = (dqR_prim_dx_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), & - & idx_right_phys(3))/Re_R(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(momxb + i - 1)%sf(j, k, l)/Re_L(2)) vel_grad_R(i, 2) = (dqR_prim_dy_vf(momxb + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + & 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(momxb + i - 1)%sf(j, k, l)/Re_L(2)) vel_grad_R(i, 3) = (dqR_prim_dz_vf(momxb + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) end if #:endif end do if (norm_dir == 1) then flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1) + vel_grad_R(1, 1)) + & 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1)*vel_L(1) + vel_grad_R(1, 1)*vel_R(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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & - & 2) + vel_grad_R(2, 2)) + & 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & - & 2)*vel_L(1) + vel_grad_R(2, 2)*vel_R(1)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(1) + vel_grad_R(3, 3)*vel_R(1)) + & 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 @@ -1690,40 +1652,40 @@ contains else if (norm_dir == 2) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1)*vel_L(2) + vel_grad_R(1, 1)*vel_R(2)) + & 1)*vel_L(2) + vel_grad_R(1, 1)*vel_R(2)) flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & - & 2)*vel_L(2) + vel_grad_R(2, 2)*vel_R(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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(2) + vel_grad_R(3, 3)*vel_R(2)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1)*vel_L(3) + vel_grad_R(1, 1)*vel_R(3)) + & 1)*vel_L(3) + vel_grad_R(1, 1)*vel_R(3)) flux_src_vf(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & - & 2)*vel_L(3) + vel_grad_R(2, 2)*vel_R(3)) + & 2)*vel_L(3) + vel_grad_R(2, 2)*vel_R(3)) flux_src_vf(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(3, & - & 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) + & 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) #:endif end if end if @@ -1735,6 +1697,7 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) end subroutine s_lf_riemann_solver + !> This procedure is the implementation of the Harten, Lax, van Leer, and contact (HLLC) approximate Riemann solver, see Toro !! (1999) and Johnsen (2007). The viscous and the surface tension effects have been included by modifying the exact Riemann !! solver of Perigaud and Saurel (2005). @@ -1761,16 +1724,15 @@ contains !! @param iy Index bounds in the y-dir !! @param iz Index bounds in the z-dir subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & - & dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, & - & flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -1849,16 +1811,15 @@ contains 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 + 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, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction @@ -1916,7 +1877,7 @@ contains do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, & - & E_idx + i)), 1._wp) + & E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) end do @@ -1924,16 +1885,16 @@ contains do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, E_idx + i)), 1._wp) + & k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, & - & E_idx + i)/max(alpha_L_sum, sgm_eps) + & E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & E_idx + i)/max(alpha_R_sum, sgm_eps) + & E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -2033,15 +1994,15 @@ contains @: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) + & 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) + & 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) + & 0._wp, c_avg, qv_avg) if (viscous) then $:GPU_LOOP(parallelism='[seq]') @@ -2059,23 +2020,23 @@ contains if (wave_speeds == 1) then if (elasticity) then s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & - & ))/rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) & - & + tau_e_R(dir_idx_tau(1)))/rho_R)) + & ))/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)) + & ))/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)))) + & + 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)))) + & - 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 == 2) 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)))) @@ -2083,11 +2044,11 @@ contains pres_SR = pres_SL 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))))) + & 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))))) + & 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 @@ -2115,15 +2076,15 @@ contains xi_PP = max(0._wp, sign(1._wp, s_R)) E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))*(rho_L*s_S + pres_L/(s_L & - & - vel_L(dir_idx(1))))) - E_L)) + 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)) + & - 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))))) + & + 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))) + & - vel_R(dir_idx(1))) ! Low Mach correction if (low_Mach == 1) then @@ -2137,8 +2098,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & - & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! MOMENTUM FLUX. @@ -2146,10 +2107,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & contxe + 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 + & contxe + 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. @@ -2163,14 +2123,12 @@ contains do i = 1, num_dims ! MOMENTUM ELASTIC FLUX. flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) - xi_M*tau_e_L(dir_idx_tau(i)) & - & - xi_P*tau_e_R(dir_idx_tau(i)) + & contxe + 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)))))) + & + 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_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e end if @@ -2179,17 +2137,16 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*s_S + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S + & i)*s_S + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S end do ! SOURCE TERM FOR VOLUME FRACTION ADVECTION FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & - & *(s_S*(xi_MP*(xi_L - 1) + 1) - vel_L(dir_idx(i)))) & - & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_PP*(xi_R - 1) & - & + 1) - vel_R(dir_idx(i)))) + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_MP*(xi_L - 1) + 1) & + & - vel_L(dir_idx(i)))) + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_PP*(xi_R & + & - 1) + 1) - vel_R(dir_idx(i)))) end do ! INTERNAL ENERGIES ADVECTION FLUX. @@ -2197,19 +2154,17 @@ contains $: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) + & + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_L) + pres_L) + xi_P*(xi_PP*((pres_R & + & + pi_infs(i)/(1._wp + gammas(i)))*xi_R**(1._wp/gammas(i) + 1._wp) - pi_infs(i)/(1._wp & + & + gammas(i)) - pres_R) + pres_R) flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = ((xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i + advxb - 1))*(gammas(i)*p_K_Star + pi_infs(i)) & - & + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i + contxb - 1))*qvs(i))*vel_K_Star + (s_M/s_L)*(s_P/s_R) & - & *pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) + & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i + advxb - 1))*(gammas(i)*p_K_Star + pi_infs(i)) + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i + contxb - 1))*qvs(i))*vel_K_Star + (s_M/s_L)*(s_P/s_R) & + & *pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) end do flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) @@ -2219,9 +2174,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, strxe - strxb + 1 flux_rs${XYZ}$_vf(j, k, l, & - & strxb - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & - & - rho_L*vel_L(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)) + & strxb - 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 @@ -2230,16 +2185,16 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & xibeg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - & - rho_L*vel_L(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)) + & xibeg - 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_rs${XYZ}$_vf(j, k, l, c_idx) = (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & c_idx) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S + & c_idx) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S end if ! Geometrical source flux for cylindrical coordinates @@ -2256,7 +2211,7 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb - 1 + dir_idx(1)) - p_Star + & momxb - 1 + dir_idx(1)) - p_Star ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -2271,7 +2226,7 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb - 1 + dir_idx(1)) - p_Star + & momxb - 1 + dir_idx(1)) - p_Star flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if @@ -2348,35 +2303,35 @@ contains @: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) + & 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) + & 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) + & 0._wp, c_avg, qv_avg) if (wave_speeds == 1) then s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & - & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L - vel_L(dir_idx(1))) & - & - rho_R*(s_R - vel_R(dir_idx(1)))) + & - 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 == 2) 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 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))))) + & 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))))) + & 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 @@ -2401,8 +2356,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = xi_M*alpha_rho_L(i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*alpha_rho_R(i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i) = xi_M*alpha_rho_L(i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*alpha_rho_R(i) & + & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Momentum flux. @@ -2410,12 +2365,11 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_L) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_R) + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i)))*vel_L(dir_idx(i))) & + & - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_L) + xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(i)) + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_R) end do if (bubbles_euler) then @@ -2423,8 +2377,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) + xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & - & + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) + & contxe + dir_idx(i)) + xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & + & + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) end do end if @@ -2433,8 +2387,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = alf_idx, alf_idx ! only advect the void fraction flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & - & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation @@ -2451,9 +2405,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = bubxb, bubxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do end if @@ -2468,12 +2421,11 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & - & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) + xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -2488,12 +2440,11 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) - xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -2582,9 +2533,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 1, Re_size(i) Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res_gs(i, & - & q) + Re_L(i) + & q) + Re_L(i) Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, & - & q)))/Res_gs(i, q) + Re_R(i) + & q)))/Res_gs(i, q) + Re_R(i) end do Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) @@ -2692,15 +2643,15 @@ contains 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) + & 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) + & 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) + & 0._wp, c_avg, qv_avg) if (viscous) then $:GPU_LOOP(parallelism='[seq]') @@ -2719,19 +2670,19 @@ contains 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)))) + & - 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 == 2) 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 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))))) + & 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))))) + & 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 @@ -2763,8 +2714,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & - & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do if (bubbles_euler .and. (num_fluids > 1)) then @@ -2794,39 +2745,36 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) & - & + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i)))*vel_L(dir_idx(i))) & + & - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) + xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(i)) + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) + (s_M/s_L) & + & *(s_P/s_R)*dir_flg(dir_idx(i))*pcorr end do ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = xi_M*(vel_L(dir_idx(1))*(E_L + pres_L) + 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 + & E_idx) = 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 = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & - & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L & - & - 1._wp)) + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R & - & - 1._wp)) + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L - 1._wp)) & + & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R - 1._wp)) ! IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp end do @@ -2837,21 +2785,20 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = bubxb, bubxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, & + & k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do if (qbmm) then flux_rs${XYZ}$_vf(j, k, l, & - & bubxb) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & bubxb) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if if (adv_n) then flux_rs${XYZ}$_vf(j, k, l, & - & n_idx) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & n_idx) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if ! Geometrical source flux for cylindrical coordinates @@ -2864,12 +2811,11 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & - & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) + xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -2885,12 +2831,11 @@ contains end do flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) - xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -2941,10 +2886,10 @@ contains do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, & - & E_idx + i)), 1._wp) + & E_idx + i)), 1._wp) qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, E_idx + i)), 1._wp) + & k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do @@ -2952,9 +2897,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, & - & E_idx + i)/max(alpha_L_sum, sgm_eps) + & E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & E_idx + i)/max(alpha_R_sum, sgm_eps) + & E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -3115,15 +3060,15 @@ contains @: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) + & 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) + & 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) + & c_sum_Yi_Phi, c_avg, qv_avg) if (viscous) then if (chemistry) then @@ -3143,23 +3088,23 @@ contains if (wave_speeds == 1) then if (elasticity) then s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & - & ))/rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) & - & + tau_e_R(dir_idx_tau(1)))/rho_R)) + & ))/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)) + & ))/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)))) + & + 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)))) + & - 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 == 2) 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)))) @@ -3167,11 +3112,11 @@ contains pres_SR = pres_SL 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))))) + & 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))))) + & 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 @@ -3205,8 +3150,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & - & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! MOMENTUM FLUX. @@ -3214,23 +3159,21 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) & - & + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i)))*vel_L(dir_idx(i))) & + & - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) + xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(i)) + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) + (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_rs${XYZ}$_vf(j, k, l, & - & E_idx) = 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 + & E_idx) = 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 ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux if (elasticity) then @@ -3239,14 +3182,12 @@ contains do i = 1, num_dims ! MOMENTUM ELASTIC FLUX. flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) - xi_M*tau_e_L(dir_idx_tau(i)) & - & - xi_P*tau_e_R(dir_idx_tau(i)) + & contxe + 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)))))) + & + 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_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e end if @@ -3256,9 +3197,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, strxe - strxb + 1 flux_rs${XYZ}$_vf(j, k, l, & - & strxb - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & - & - rho_L*vel_L(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)) + & strxb - 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 @@ -3266,25 +3207,23 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & - & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! VOLUME FRACTION SOURCE FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L & - & - 1._wp)) + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R & - & - 1._wp)) + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L - 1._wp)) & + & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R - 1._wp)) end do ! COLOR FUNCTION FLUX if (surface_tension) then flux_rs${XYZ}$_vf(j, k, l, c_idx) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & c_idx)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & c_idx)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & c_idx)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, & + & l, c_idx)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if ! REFERENCE MAP FLUX. @@ -3292,9 +3231,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & xibeg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - & - rho_L*vel_L(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)) + & xibeg - 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 @@ -3307,8 +3246,8 @@ contains Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) flux_rs${XYZ}$_vf(j, k, l, & - & i) = xi_M*rho_L*Y_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*rho_R*Y_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i) = xi_M*rho_L*Y_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*rho_R*Y_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0.0_wp end do end if @@ -3323,12 +3262,11 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & - & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) + xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -3344,12 +3282,11 @@ contains end do flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) - xi_P*(rho_R*(vel_R(dir_idx(1)) & + & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -3365,37 +3302,35 @@ contains if (viscous .or. dummy) then if (weno_Re_flux) then call s_compute_viscous_source_flux(qL_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & - & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & - & qR_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & - & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), qR_prim_vf(momxb:momxe), & + & dqR_prim_dx_vf(momxb:momxe), dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) else call s_compute_viscous_source_flux(q_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & - & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & - & q_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & - & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), q_prim_vf(momxb:momxe), & + & dqR_prim_dx_vf(momxb:momxe), dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) end if end if if (surface_tension) then call s_compute_capillary_source_flux(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf, flux_src_vf, norm_dir, isx, isy, & - & isz) + & isz) end if call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) end subroutine s_hllc_riemann_solver + !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: 1 entropy wave, 2 Alfven waves, 2 fast magnetosonic waves. subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & - & dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, & - & flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -3432,9 +3367,8 @@ contains integer :: i, j, k, l call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) call s_initialize_riemann_solver(flux_src_vf, norm_dir) @@ -3475,16 +3409,15 @@ contains if (mhd) then if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + 1)] + & B_idx%beg + 1)] B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & B_idx%beg + 1)] + & B_idx%beg + 1)] else ! 2D/3D: Bx, By, Bz as variables B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), qL_prim_rs${XYZ}$_vf(j, k, & - & l, B_idx%beg + dir_idx(2) - 1), qL_prim_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + dir_idx(3) - 1)] + & l, B_idx%beg + dir_idx(2) - 1), qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & - & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & - & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] + & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & + & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] end if end if @@ -3510,13 +3443,13 @@ contains E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L H_no_mag%R = (E%R + pres%R - pres_mag%R) & - & /rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) ! (2) Compute fast wave speeds call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, & - & 0._wp, c%L, qv%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) + & 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) @@ -3528,7 +3461,7 @@ contains 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)) + & - 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) @@ -3572,14 +3505,14 @@ contains 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 + & - 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 + & - 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 + & + 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 + & + 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, & @@ -3635,6 +3568,7 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) end subroutine s_hlld_riemann_solver + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_riemann_solvers_module @@ -3716,6 +3650,7 @@ contains @:ALLOCATE(Re_avg_rsz_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:2)) end if end subroutine s_initialize_riemann_solvers_module + !> The purpose of this subroutine is to populate the buffers of the left and right Riemann states variables, depending on the !! boundary conditions. !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) @@ -3735,15 +3670,14 @@ contains !! @param iy Index bounds in the y-dir !! @param iz Index bounds in the z-dir subroutine s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -4066,6 +4000,7 @@ contains end if ! END: Population of Buffers in z-direction end subroutine s_populate_riemann_states_variables_buffers + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures needed to configure the chosen Riemann solver algorithm. !! @param flux_src_vf Intra-cell fluxes sources @@ -4216,6 +4151,7 @@ contains end if end if end subroutine s_initialize_riemann_solver + !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. Calculates Cartesian components of the !! stress tensor using averaged velocity derivatives and cylindrical geometric factors, then updates `flux_src_vf`. Assumes !! x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). @@ -4233,7 +4169,7 @@ contains !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & - & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) + & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf @@ -4251,19 +4187,19 @@ contains 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. real(wp), & - & dimension(3) & - & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + & dimension(3) & + & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). #:else real(wp), & - & dimension(num_dims) :: avg_v_int !!< Averaged interface velocity (\f$v_x, v_y, v_z\f$) (grid directions). + & 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). real(wp), & - & dimension(num_dims) :: vel_src_int !!< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. + & dimension(num_dims) :: vel_src_int !!< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. real(wp), & - & dimension(num_dims) & - & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + & dimension(num_dims) & + & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). #: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. @@ -4290,16 +4226,16 @@ contains 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))) + & 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))) + & 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))) + & idx_rp(2), idx_rp(3))) else avg_dvdz_int(i_vel) = 0.0_wp end if @@ -4361,7 +4297,7 @@ contains 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 + & )/Re_s #:endif end if #:endif @@ -4374,7 +4310,7 @@ contains 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 + & + div_v_term_const #:endif end if end select @@ -4382,9 +4318,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i_vel = 1, num_dims flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, & - & l) - stress_vector_shear(i_vel) + & l) - stress_vector_shear(i_vel) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) + & l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) end do end if @@ -4392,7 +4328,7 @@ contains stress_normal_bulk = divergence_cyl/Re_b flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, & - & l) - stress_normal_bulk + & l) - stress_normal_bulk flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk end if end do @@ -4400,6 +4336,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_compute_cylindrical_viscous_source_flux + !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. Calculates averaged velocity gradients, !! gets Re and interface velocities, calls helpers for shear/bulk stress, then updates `flux_src_vf`. !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). @@ -4411,7 +4348,7 @@ contains !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). 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, norm_dir) + & dvelR_dz_vf, flux_src_vf, norm_dir) ! Arguments type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf @@ -4422,20 +4359,20 @@ contains ! 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. + 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. + & 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, 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. @@ -4456,20 +4393,19 @@ contains 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))) + & 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))) + & 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))) + & 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 @@ -4506,10 +4442,10 @@ contains do i_dim = 1, num_dims flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = flux_src_vf(momxb + i_dim - 1)%sf(j_loop, & - & k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + & k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = flux_src_vf(E_idx)%sf(j_loop, k_loop, & - & l_loop) - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + & l_loop) - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) end do end if @@ -4519,10 +4455,10 @@ contains do i_dim = 1, num_dims flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = flux_src_vf(momxb + i_dim - 1)%sf(j_loop, & - & k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + & k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = flux_src_vf(E_idx)%sf(j_loop, k_loop, & - & l_loop) - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + & l_loop) - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) end do end if end do @@ -4530,6 +4466,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_compute_cartesian_viscous_source_flux + !> @brief Calculates shear stress tensor components. tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). !! @param[in] Re_shear Shear Reynolds number. @@ -4564,6 +4501,7 @@ contains end do end do end subroutine s_calculate_shear_stress_tensor + !> @brief Calculates bulk stress tensor components (diagonal only). tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. !! @param[in] Re_bulk Bulk Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). @@ -4589,6 +4527,7 @@ contains tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk end do end subroutine s_calculate_bulk_stress_tensor + !> Deallocation and/or disassociation procedures that are needed to finalize the selected Riemann problem solver !! @param flux_vf Intercell fluxes !! @param flux_src_vf Intercell source fluxes @@ -4738,6 +4677,7 @@ contains end if end if end subroutine s_finalize_riemann_solver + !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_riemann_solvers_module if (viscous) then diff --git a/src/simulation/m_sim_helpers.fpp b/src/simulation/m_sim_helpers.fpp index 3f2612aa0a..08731acd14 100644 --- a/src/simulation/m_sim_helpers.fpp +++ b/src/simulation/m_sim_helpers.fpp @@ -8,9 +8,7 @@ !> @brief Simulation helper routines for enthalpy computation, CFL calculation, and stability checks module m_sim_helpers use m_derived_types !< Definitions of the derived types - use m_global_parameters - use m_variables_conversion implicit none @@ -41,6 +39,7 @@ contains fltr_dtheta = 0._wp end if end function f_compute_filtered_dtheta + !> Computes inviscid CFL terms for multi-dimensional cases (2D/3D only) !! @param vel directional velocities !! @param c mixture speed of sound @@ -72,6 +71,7 @@ contains cfl_terms = min(dx(j)/(abs(vel(1)) + c), dy(k)/(abs(vel(2)) + c)) end if end function f_compute_multidim_cfl_terms + !> Computes enthalpy !! @param q_prim_vf cell centered primitive variables !! @param pres mixture pressure @@ -151,6 +151,7 @@ contains H = (E + pres)/rho end subroutine s_compute_enthalpy + !> Computes stability criterion for a specified dt !! @param vel directional velocities !! @param c mixture speed of sound @@ -190,11 +191,11 @@ contains fltr_dtheta = f_compute_filtered_dtheta(k, l) vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/min(dx(j), dy(k), fltr_dtheta)**2._wp Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), dy(k)*(abs(vel(2)) + c), & - & fltr_dtheta*(abs(vel(3)) + c))/maxval(1._wp/Re_l) + & fltr_dtheta*(abs(vel(3)) + c))/maxval(1._wp/Re_l) else vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/min(dx(j), dy(k), dz(l))**2._wp Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), dy(k)*(abs(vel(2)) + c), & - & dz(l)*(abs(vel(3)) + c))/maxval(1._wp/Re_l) + & dz(l)*(abs(vel(3)) + c))/maxval(1._wp/Re_l) end if #:endif else if (n > 0) then @@ -208,6 +209,7 @@ contains end if end if end subroutine s_compute_stability_from_dt + !> Computes dt for a specified CFL number !! @param vel directional velocities !! @param c Speed of sound diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 0e48d9c4f8..8acc84f817 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -8,15 +8,10 @@ !> @brief Reads input files, loads initial conditions and grid data, and orchestrates solver initialization and finalization module m_start_up use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_mpi_common - use m_variables_conversion !< State variables type conversion procedures - use m_weno !< Weighted and essentially non-oscillatory (WENO) !! schemes for spatial reconstruction of variables @@ -24,61 +19,36 @@ module m_start_up !! schemes for convservation laws use m_riemann_solvers !< Exact and approximate Riemann problem solvers - use m_cbc !< Characteristic boundary conditions (CBC) - use m_boundary_common - use m_acoustic_src !< Acoustic source calculations - use m_rhs !< Right-hand-side (RHS) evaluation procedures - use m_chemistry !< Chemistry module - use m_data_output !< Run-time info & solution data output procedures - use m_time_steppers !< Time-stepping algorithms - use m_qbmm !< Quadrature MOM - use m_derived_variables !< Procedures used to compute quantities derived !! from the conservative and primitive variables use m_hypoelastic - use m_hyperelastic - use m_phase_change !< Phase-change module - use m_viscous - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL !< Lagrange bubble dynamics routines - use ieee_arithmetic - use m_helper_basic !< Functions to compare floating point numbers - use m_helper $:USE_GPU_MODULE() use m_nvtx - use m_ibm - use m_compile_specific - use m_checker_common - use m_checker - use m_surface_tension - use m_body_forces - use m_sim_helpers - use m_igr implicit none @@ -102,6 +72,7 @@ contains call s_read_parallel_data_files(q_cons_vf) end if end subroutine s_read_data_files + !> The purpose of this procedure is to first verify that an input file has been made available by the user. Provided that this !! is so, the input file is then read in. impure subroutine s_read_input_file @@ -184,6 +155,7 @@ contains call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if end subroutine s_read_input_file + !> The goal of this procedure is to verify that each of the user provided inputs is valid and that their combination constitutes !! a meaningful configuration for the simulation. impure subroutine s_check_input_file @@ -205,6 +177,7 @@ contains call s_check_inputs_common() call s_check_inputs() end subroutine s_check_input_file + !> @brief Reads serial initial condition and grid data files and computes cell-width distributions. !! @param q_cons_vf Cell-averaged conservative variables impure subroutine s_read_serial_data_files(q_cons_vf) @@ -260,7 +233,7 @@ contains do i = 1, num_ibs if (patch_ib(i)%c > 0) then Np = int((patch_ib(i)%p*patch_ib(i)%c/dx(0))*20) + int(((patch_ib(i)%c - patch_ib(i)%p*patch_ib(i)%c)/dx(0)) & - & *20) + 1 + & *20) + 1 end if end do end if @@ -340,6 +313,7 @@ contains end if end if end subroutine s_read_serial_data_files + !> @brief Reads parallel initial condition and grid data files via MPI I/O. !! @param q_cons_vf Conservative variables impure subroutine s_read_parallel_data_files(q_cons_vf) @@ -403,7 +377,7 @@ contains do i = 1, num_ibs if (patch_ib(i)%c > 0) then Np = int((patch_ib(i)%p*patch_ib(i)%c/dx(0))*20) + int(((patch_ib(i)%c - patch_ib(i)%p*patch_ib(i)%c)/dx(0)) & - & *20) + 1 + & *20) + 1 allocate (MPI_IO_airfoil_IB_DATA%var(1:2*Np)) end if end do @@ -622,6 +596,7 @@ contains end if #endif end subroutine s_read_parallel_data_files + !> The purpose of this procedure is to initialize the values of the internal-energy equations of each phase from the mass of !! each phase, the mixture momentum and mixture-total-energy equations. !! @param v_vf conservative variables @@ -663,21 +638,22 @@ contains pres_mag = 0.5_wp*(Bx0**2 + v_vf(B_idx%beg)%sf(j, k, l)**2 + v_vf(B_idx%beg + 1)%sf(j, k, l)**2) else pres_mag = 0.5_wp*(v_vf(B_idx%beg)%sf(j, k, l)**2 + v_vf(B_idx%beg + 1)%sf(j, k, & - & l)**2 + v_vf(B_idx%beg + 2)%sf(j, k, l)**2) + & l)**2 + v_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if end if call s_compute_pressure(v_vf(E_idx)%sf(j, k, l), 0._stp, dyn_pres, pi_inf, gamma, rho, qv, rhoYks, pres, T, & - & pres_mag=pres_mag) + & pres_mag=pres_mag) do i = 1, num_fluids v_vf(i + intxb - 1)%sf(j, k, l) = v_vf(i + advxb - 1)%sf(j, k, & - & l)*(gammas(i)*pres + pi_infs(i)) + v_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) + & l)*(gammas(i)*pres + pi_infs(i)) + v_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) end do end do end do end do end subroutine s_initialize_internal_energy_equations + !> @brief Advances the simulation by one time step, handling CFL-based dt and time-stepper dispatch. impure subroutine s_perform_time_step(t_step, time_avg) integer, intent(inout) :: t_step @@ -738,9 +714,10 @@ contains ! Time-stepping loop controls t_step = t_step + 1 end subroutine s_perform_time_step + !> @brief Collects per-process wall-clock times and writes aggregate performance metrics to file. impure subroutine s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & - & file_exists) + & file_exists) real(wp), intent(inout) :: time_avg, time_final real(wp), intent(inout) :: io_time_avg, io_time_final @@ -769,7 +746,7 @@ contains end if grind_time = time_final*1.0e9_wp/(real(sys_size, wp)*real(maxval((/1, m_glb/)), wp)*real(maxval((/1, n_glb/)), & - & wp)*real(maxval((/1, p_glb/)), wp)) + & wp)*real(maxval((/1, p_glb/)), wp)) print *, "Performance:", grind_time, "ns/gp/eq/rhs" inquire (FILE='time_data.dat', EXIST=file_exists) @@ -796,6 +773,7 @@ contains close (1) end if end subroutine s_save_performance_metrics + !> @brief Saves conservative variable data to disk at the current time step. impure subroutine s_save_data(t_step, start, finish, io_time_avg, nt) integer, intent(inout) :: t_step @@ -856,8 +834,8 @@ contains end if if (bubbles_lagrange) then - $:GPU_UPDATE(host='[lag_id, mtn_pos, mtn_posPrev, mtn_vel, intfc_rad, & - & intfc_vel, bub_R0, Rmax_stats, Rmin_stats, bub_dphidt, gas_p, gas_mv, gas_mg, gas_betaT, gas_betaC]') + $:GPU_UPDATE(host='[lag_id, mtn_pos, mtn_posPrev, mtn_vel, intfc_rad, intfc_vel, bub_R0, Rmax_stats, Rmin_stats, & + & bub_dphidt, gas_p, gas_mv, gas_mg, gas_betaT, gas_betaC]') do i = 1, nBubs if (ieee_is_nan(intfc_rad(i, 1)) .or. intfc_rad(i, 1) <= 0._wp) then call s_mpi_abort("Bubble radius is negative or NaN, please reduce dt.") @@ -887,6 +865,7 @@ contains io_time_avg = (abs(finish - start) + io_time_avg*(nt - 1))/nt end if end subroutine s_save_data + !> @brief Initializes all simulation sub-modules in the required dependency order. impure subroutine s_initialize_modules integer :: m_ds, n_ds, p_ds @@ -994,6 +973,7 @@ contains if (hypoelasticity) call s_initialize_hypoelastic_module() if (hyperelasticity) call s_initialize_hyperelastic_module() end subroutine s_initialize_modules + !> @brief Sets up the MPI execution environment, binds GPUs, and decomposes the computational domain. impure subroutine s_initialize_mpi_domain integer :: ierr @@ -1071,6 +1051,7 @@ contains call s_mpi_decompose_computational_domain() end subroutine s_initialize_mpi_domain + !> @brief Transfers initial conservative variable and model parameter data to the GPU device. subroutine s_initialize_gpu_vars integer :: i @@ -1090,16 +1071,15 @@ contains $:GPU_UPDATE(device='[chem_params]') - $:GPU_UPDATE(device='[R0ref,p0ref,rho0ref,ss,pv,vd,mu_l,mu_v,mu_g, & - & gam_v, gam_g, M_v, M_g, R_v, R_g, Tw, cp_v, cp_g, k_vl, k_gl, gam, gam_m, Eu, Ca, Web, Re_inv, Pe_c, phi_vg, phi_gv, & - & omegaN, bubbles_euler, polytropic, polydisperse, qbmm, ptil, bubble_model, thermal, poly_sigma, adv_n, adap_dt, & - & adap_dt_tol, adap_dt_max_iters, n_idx, pi_fac, low_Mach]') + $:GPU_UPDATE(device='[R0ref, p0ref, rho0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, R_v, R_g, Tw, cp_v, & + & cp_g, k_vl, k_gl, gam, gam_m, Eu, Ca, Web, Re_inv, Pe_c, phi_vg, phi_gv, omegaN, bubbles_euler, polytropic, & + & polydisperse, qbmm, ptil, bubble_model, thermal, poly_sigma, adv_n, adap_dt, adap_dt_tol, adap_dt_max_iters, n_idx, & + & pi_fac, low_Mach]') if (bubbles_euler) then $:GPU_UPDATE(device='[weight, R0]') if (.not. polytropic) then - $:GPU_UPDATE(device='[pb0,Pe_T,k_g,k_v,mass_g0,mass_v0, & - & Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c]') + $:GPU_UPDATE(device='[pb0, Pe_T, k_g, k_v, mass_g0, mass_v0, Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c]') else if (qbmm) then $:GPU_UPDATE(device='[pb0]') end if @@ -1139,6 +1119,7 @@ contains end block #:endif end subroutine s_initialize_gpu_vars + !> @brief Finalizes and deallocates all simulation sub-modules in reverse initialization order. impure subroutine s_finalize_modules call s_finalize_time_steppers_module() diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index 56f70418e5..fca258e86a 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -9,20 +9,14 @@ !> @brief Computes capillary source fluxes and color-function gradients for the diffuse-interface surface tension model module m_surface_tension use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion - use m_weno - use m_muscl !< Monotonic Upstream-centered (MUSCL) !! schemes for conservation laws use m_helper - use m_boundary_common implicit none @@ -67,6 +61,7 @@ contains @:ALLOCATE(gR_z(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, num_dims + 1)) end if end subroutine s_initialize_surface_tension_module + !> @brief Computes the capillary (surface-tension) source flux from reconstructed color-gradient fields. subroutine s_compute_capillary_source_flux(vSrc_rsx_vf, vSrc_rsy_vf, vSrc_rsz_vf, flux_src_vf, id, isx, isy, isz) real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsx_vf @@ -114,11 +109,11 @@ contains flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(1, i) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(1, i)*vSrc_rsx_vf(j, k, & - & l, i) + & l, i) end do flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + sigma*c_divs(num_dims + 1)%sf(j, k, & - & l)*vSrc_rsx_vf(j, k, l, 1) + & l)*vSrc_rsx_vf(j, k, l, 1) end if end do end do @@ -155,11 +150,11 @@ contains flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(2, i) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(2, i)*vSrc_rsy_vf(k, & - & j, l, i) + & j, l, i) end do flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsy_vf(k, j, l, 2) + & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsy_vf(k, j, l, 2) end if end do end do @@ -197,11 +192,11 @@ contains flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(3, i) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(3, i)*vSrc_rsz_vf(l, & - & k, j, i) + & k, j, i) end do flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsz_vf(l, k, j, 3) + & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsz_vf(l, k, j, 3) end if end do end do @@ -210,6 +205,7 @@ contains #:endif end if end subroutine s_compute_capillary_source_flux + !> @brief Computes color-function gradients and their norms, then reconstructs them at cell boundaries. impure subroutine s_get_capillary(q_prim_vf, bc_type) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -229,7 +225,7 @@ contains do k = 0, n do j = 0, m c_divs(1)%sf(j, k, l) = 1._wp/(x_cc(j + 1) - x_cc(j - 1))*(q_prim_vf(c_idx)%sf(j + 1, k, & - & l) - q_prim_vf(c_idx)%sf(j - 1, k, l)) + & l) - q_prim_vf(c_idx)%sf(j - 1, k, l)) end do end do end do @@ -240,7 +236,7 @@ contains do k = 0, n do j = 0, m c_divs(2)%sf(j, k, l) = 1._wp/(y_cc(k + 1) - y_cc(k - 1))*(q_prim_vf(c_idx)%sf(j, k + 1, & - & l) - q_prim_vf(c_idx)%sf(j, k - 1, l)) + & l) - q_prim_vf(c_idx)%sf(j, k - 1, l)) end do end do end do @@ -252,7 +248,7 @@ contains do k = 0, n do j = 0, m c_divs(3)%sf(j, k, l) = 1._wp/(z_cc(l + 1) - z_cc(l - 1))*(q_prim_vf(c_idx)%sf(j, k, & - & l + 1) - q_prim_vf(c_idx)%sf(j, k, l - 1)) + & l + 1) - q_prim_vf(c_idx)%sf(j, k, l - 1)) end do end do end do @@ -285,6 +281,7 @@ contains call s_reconstruct_cell_boundary_values_capillary(c_divs, gL_x, gL_y, gL_z, gR_x, gR_y, gR_z, i) end do end subroutine s_get_capillary + !> @brief Reconstructs left and right cell-boundary values of capillary (color-gradient) variables using WENO or MUSCL. subroutine s_reconstruct_cell_boundary_values_capillary(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf @@ -357,6 +354,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_reconstruct_cell_boundary_values_capillary + !> @brief Deallocates the color-gradient divergence and reconstructed boundary arrays for surface tension. impure subroutine s_finalize_surface_tension_module integer :: j diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 3aeaf17eaf..41e09a94f9 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -8,39 +8,22 @@ !> @brief Total-variation-diminishing (TVD) Runge--Kutta time integrators (1st-, 2nd-, and 3rd-order SSP) module m_time_steppers use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_rhs !< Right-hane-side (RHS) evaluation procedures - use m_pressure_relaxation !< Pressure relaxation procedures - use m_data_output !< Run-time info & solution data output procedures - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL !< Lagrange bubble dynamics routines - use m_ibm - use m_hyperelastic - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_boundary_common - use m_helper - use m_sim_helpers - use m_fftw - use m_nvtx - use m_thermochem, only: num_species - use m_body_forces - use m_derived_variables implicit none @@ -125,7 +108,7 @@ contains if (num_ts == 2 .and. nv_uvm_out_of_core) then ! host allocation for q_cons_ts(2)%vf(j)%sf for all j allocate (q_cons_ts_pool_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + & idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) end if do j = 1, sys_size @@ -136,7 +119,7 @@ contains if (nv_uvm_out_of_core) then ! q_cons_ts(2) lives on the host q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) else @:ALLOCATE(q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(q_cons_ts(2)%vf(j)%sf) @@ -158,7 +141,7 @@ contains pool_starts(4) = 1 #ifdef MFC_MIXED_PRECISION pool_size = 1_8*(idwbuff(1)%end - idwbuff(1)%beg + 1)*(idwbuff(2)%end - idwbuff(2)%beg + 1)*(idwbuff(3)%end - idwbuff(3) & - & %beg + 1)*sys_size + & %beg + 1)*sys_size call hipCheck(hipMalloc_(cptr_device, pool_size*2_8)) call c_f_pointer(cptr_device, q_cons_ts_pool_device, shape=pool_dims) q_cons_ts_pool_device(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:) => q_cons_ts_pool_device @@ -180,7 +163,7 @@ contains call hipCheck(hipMallocManaged(q_cons_ts_pool_host, dims8=pool_dims, lbounds8=pool_starts, flags=hipMemAttachGlobal)) #if defined(MFC_OpenMP) call hipCheck(hipMemAdvise(c_loc(q_cons_ts_pool_host), c_sizeof(q_cons_ts_pool_host), & - & hipMemAdviseSetPreferredLocation, -1)) + & hipMemAdviseSetPreferredLocation, -1)) #endif end if #endif @@ -188,11 +171,11 @@ contains do j = 1, sys_size ! q_cons_ts(1) lives on the device q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_device(:,:,:, j) + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_device(:,:,:, j) if (num_ts == 2) then ! q_cons_ts(2) lives on the host q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) end if end do @@ -451,6 +434,7 @@ contains $:GPU_UPDATE(device='[rk_coef, stor]') end if end subroutine s_initialize_time_steppers_module + !> @brief Advances the solution one full step using a TVD Runge-Kutta time integrator. impure subroutine s_tvd_rk(t_step, time_avg, nstage) #ifdef _CRAYFTN @@ -471,7 +455,7 @@ contains do s = 1, nstage call s_compute_rhs(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_ts(1)%sf, rhs_pb, mv_ts(1)%sf, rhs_mv, & - & t_step, time_avg, s) + & t_step, time_avg, s) if (s == 1) then if (run_time_info) then @@ -506,12 +490,10 @@ contains end if if (igr) then q_cons_ts(1)%vf(i)%sf(j, k, l) = (rk_coef(s, 1)*q_cons_ts(1)%vf(i)%sf(j, k, l) + rk_coef(s, & - & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*rhs_vf(i)%sf(j, k, & - & l))/rk_coef(s, 4) + & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*rhs_vf(i)%sf(j, k, l))/rk_coef(s, 4) else q_cons_ts(1)%vf(i)%sf(j, k, l) = (rk_coef(s, 1)*q_cons_ts(1)%vf(i)%sf(j, k, l) + rk_coef(s, & - & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*dt*rhs_vf(i)%sf(j, k, & - & l))/rk_coef(s, 4) + & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*dt*rhs_vf(i)%sf(j, k, l))/rk_coef(s, 4) end if end do end do @@ -531,9 +513,9 @@ contains mv_ts(stor)%sf(j, k, l, q, i) = mv_ts(1)%sf(j, k, l, q, i) end if pb_ts(1)%sf(j, k, l, q, i) = (rk_coef(s, 1)*pb_ts(1)%sf(j, k, l, q, i) + rk_coef(s, & - & 2)*pb_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_pb(j, k, l, q, i))/rk_coef(s, 4) + & 2)*pb_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_pb(j, k, l, q, i))/rk_coef(s, 4) mv_ts(1)%sf(j, k, l, q, i) = (rk_coef(s, 1)*mv_ts(1)%sf(j, k, l, q, i) + rk_coef(s, & - & 2)*mv_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_mv(j, k, l, q, i))/rk_coef(s, 4) + & 2)*mv_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_mv(j, k, l, q, i))/rk_coef(s, 4) end do end do end do @@ -591,6 +573,7 @@ contains wall_time_avg = 0._wp end if end subroutine s_tvd_rk + !> Bubble source part in Strang operator splitting scheme !! @param stage Current time-stage impure subroutine s_adaptive_dt_bubble(stage) @@ -617,24 +600,25 @@ contains end if end if end subroutine s_adaptive_dt_bubble + !> @brief Computes the global time step size from CFL stability constraints across all cells. impure subroutine s_compute_dt() real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: vel !< Cell-avg. velocity - real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction + real(wp), dimension(3) :: vel !< Cell-avg. velocity + real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction #:else - real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity - real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction + real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity + real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction #:endif - real(wp) :: vel_sum !< Cell-avg. velocity sum - real(wp) :: pres !< Cell-avg. pressure - real(wp) :: gamma !< Cell-avg. sp. heat ratio - real(wp) :: pi_inf !< Cell-avg. liquid stiffness function - real(wp) :: qv !< Cell-avg. fluid reference energy - real(wp) :: c !< Cell-avg. sound speed - real(wp) :: H !< Cell-avg. enthalpy - real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers + real(wp) :: vel_sum !< Cell-avg. velocity sum + real(wp) :: pres !< Cell-avg. pressure + real(wp) :: gamma !< Cell-avg. sp. heat ratio + real(wp) :: pi_inf !< Cell-avg. liquid stiffness function + real(wp) :: qv !< Cell-avg. fluid reference energy + real(wp) :: c !< Cell-avg. sound speed + real(wp) :: H !< Cell-avg. enthalpy + real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers type(vector_field) :: gm_alpha_qp real(wp) :: dt_local integer :: j, k, l !< Generic loop iterators @@ -674,6 +658,7 @@ contains $:GPU_UPDATE(device='[dt]') end subroutine s_compute_dt + !> This subroutine applies the body forces source term at each Runge-Kutta stage !! @param q_cons_vf Conservative variables !! @param q_prim_vf_in Primitive variables @@ -702,6 +687,7 @@ contains call nvtxEndRange end subroutine s_apply_bodyforces + !> @brief Updates immersed boundary positions and velocities at the current Runge-Kutta stage. subroutine s_propagate_immersed_boundaries(s) integer, intent(in) :: s @@ -725,7 +711,7 @@ contains if (patch_ib(i)%moving_ibm > 0) then patch_ib(i)%vel = (rk_coef(s, 1)*patch_ib(i)%step_vel + rk_coef(s, 2)*patch_ib(i)%vel)/rk_coef(s, 4) patch_ib(i)%angular_vel = (rk_coef(s, 1)*patch_ib(i)%step_angular_vel + rk_coef(s, & - & 2)*patch_ib(i)%angular_vel)/rk_coef(s, 4) + & 2)*patch_ib(i)%angular_vel)/rk_coef(s, 4) if (patch_ib(i)%moving_ibm == 1) then ! plug in analytic velocities for 1-way coupling, if it exists @@ -742,25 +728,25 @@ contains ! update the angular velocity with the torque value patch_ib(i)%angular_vel = (patch_ib(i)%angular_vel*patch_ib(i)%moment) + (rk_coef(s, & - & 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum + & 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum call s_compute_moment_of_inertia(i, & - & patch_ib(i)%angular_vel) & - & ! update the moment of inertia to be based on the direction of the angular momentum + & patch_ib(i)%angular_vel) & + & ! update the moment of inertia to be based on the direction of the angular momentum patch_ib(i)%angular_vel = patch_ib(i)%angular_vel/patch_ib(i) & - & %moment ! convert back to angular velocity with the new moment of inertia + & %moment ! convert back to angular velocity with the new moment of inertia end if ! Update the angle of the IB patch_ib(i)%angles = (rk_coef(s, 1)*patch_ib(i)%step_angles + rk_coef(s, 2)*patch_ib(i)%angles + rk_coef(s, & - & 3)*patch_ib(i)%angular_vel*dt)/rk_coef(s, 4) + & 3)*patch_ib(i)%angular_vel*dt)/rk_coef(s, 4) ! Update the position of the IB patch_ib(i)%x_centroid = (rk_coef(s, 1)*patch_ib(i)%step_x_centroid + rk_coef(s, & - & 2)*patch_ib(i)%x_centroid + rk_coef(s, 3)*patch_ib(i)%vel(1)*dt)/rk_coef(s, 4) + & 2)*patch_ib(i)%x_centroid + rk_coef(s, 3)*patch_ib(i)%vel(1)*dt)/rk_coef(s, 4) patch_ib(i)%y_centroid = (rk_coef(s, 1)*patch_ib(i)%step_y_centroid + rk_coef(s, & - & 2)*patch_ib(i)%y_centroid + rk_coef(s, 3)*patch_ib(i)%vel(2)*dt)/rk_coef(s, 4) + & 2)*patch_ib(i)%y_centroid + rk_coef(s, 3)*patch_ib(i)%vel(2)*dt)/rk_coef(s, 4) patch_ib(i)%z_centroid = (rk_coef(s, 1)*patch_ib(i)%step_z_centroid + rk_coef(s, & - & 2)*patch_ib(i)%z_centroid + rk_coef(s, 3)*patch_ib(i)%vel(3)*dt)/rk_coef(s, 4) + & 2)*patch_ib(i)%z_centroid + rk_coef(s, 3)*patch_ib(i)%vel(3)*dt)/rk_coef(s, 4) end if end do @@ -768,6 +754,7 @@ contains call nvtxEndRange end subroutine s_propagate_immersed_boundaries + !> This subroutine saves the temporary q_prim_vf vector into the q_prim_ts vector that is then used in p_main !! @param t_step current time-step subroutine s_time_step_cycling(t_step) @@ -839,6 +826,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_time_step_cycling + !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_time_steppers_module #ifdef FRONTIER_UNIFIED diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 38ade6dcf8..88f93b5ac5 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -7,16 +7,12 @@ !> @brief Computes viscous stress tensors and diffusive flux contributions for the Navier--Stokes equations module m_viscous use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_weno - use m_muscl !< Monotonic Upstream-centered (MUSCL) !! schemes for conservation laws use m_helper - use m_finite_differences private; public s_get_viscous, s_compute_viscous_stress_cylindrical_boundary, s_initialize_viscous_module, & @@ -44,6 +40,7 @@ contains $:GPU_UPDATE(device='[Res_viscous, Re_idx, Re_size]') $:GPU_ENTER_DATA(copyin='[is1_viscous, is2_viscous, is3_viscous, iv]') end subroutine s_initialize_viscous_module + !> The purpose of this subroutine is to compute the viscous ! stress tensor for the cells directly next to the axis in ! cylindrical coordinates. This is necessary to avoid the @@ -172,13 +169,13 @@ contains tau_Re(2, 1) = (grad_y_vf(1)%sf(j, k, l) + grad_x_vf(2)%sf(j, k, l))/Re_visc(1) tau_Re(2, 2) = (4._wp*grad_y_vf(2)%sf(j, k, l) - 2._wp*grad_x_vf(1)%sf(j, k, & - & l) - 2._wp*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/(3._wp*Re_visc(1)) + & l) - 2._wp*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/(3._wp*Re_visc(1)) $:GPU_LOOP(parallelism='[seq]') do i = 1, 2 tau_Re_vf(contxe + i)%sf(j, k, l) = tau_Re_vf(contxe + i)%sf(j, k, l) - tau_Re(2, i) tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(contxe + i)%sf(j, k, & - & l)*tau_Re(2, i) + & l)*tau_Re(2, i) end do end do end do @@ -270,12 +267,12 @@ contains end if tau_Re(2, 2) = (grad_x_vf(1)%sf(j, k, l) + grad_y_vf(2)%sf(j, k, l) + q_prim_vf(momxb + 1)%sf(j, k, & - & l)/y_cc(k))/Re_visc(2) + & l)/y_cc(k))/Re_visc(2) tau_Re_vf(momxb + 1)%sf(j, k, l) = tau_Re_vf(momxb + 1)%sf(j, k, l) - tau_Re(2, 2) tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(momxb + 1)%sf(j, k, & - & l)*tau_Re(2, 2) + & l)*tau_Re(2, 2) end do end do end do @@ -369,14 +366,14 @@ contains tau_Re(2, 2) = -(2._wp/3._wp)*grad_z_vf(3)%sf(j, k, l)/y_cc(k)/Re_visc(1) tau_Re(2, 3) = ((grad_z_vf(2)%sf(j, k, l) - q_prim_vf(momxe)%sf(j, k, & - & l))/y_cc(k) + grad_y_vf(3)%sf(j, k, l))/Re_visc(1) + & l))/y_cc(k) + grad_y_vf(3)%sf(j, k, l))/Re_visc(1) $:GPU_LOOP(parallelism='[seq]') do i = 2, 3 tau_Re_vf(contxe + i)%sf(j, k, l) = tau_Re_vf(contxe + i)%sf(j, k, l) - tau_Re(2, i) tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(contxe + i)%sf(j, k, & - & l)*tau_Re(2, i) + & l)*tau_Re(2, i) end do end do end do @@ -470,7 +467,7 @@ contains tau_Re_vf(momxb + 1)%sf(j, k, l) = tau_Re_vf(momxb + 1)%sf(j, k, l) - tau_Re(2, 2) tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(momxb + 1)%sf(j, k, & - & l)*tau_Re(2, 2) + & l)*tau_Re(2, 2) end do end do end do @@ -478,6 +475,7 @@ contains end if #:endif end subroutine s_compute_viscous_stress_cylindrical_boundary + !> Computes viscous terms !! @param qL_prim_rsx_vf Left reconstructed primitive variables in x !! @param qL_prim_rsy_vf Left reconstructed primitive variables in y @@ -501,16 +499,16 @@ contains !! @param iy Index bounds in the y-direction !! @param iz Index bounds in the z-direction subroutine s_get_viscous(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, & - & qL_prim, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, & - & dqR_prim_dz_n, qR_prim, q_prim_qp, dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, ix, iy, iz) + & qL_prim, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, & + & q_prim_qp, dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, 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, qL_prim_rsy_vf, qR_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsz_vf + & qR_prim_rsx_vf, qL_prim_rsy_vf, qR_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsz_vf type(vector_field), dimension(num_dims), intent(inout) :: qL_prim, qR_prim type(vector_field), intent(in) :: q_prim_qp type(vector_field), dimension(1:num_dims), intent(inout) :: dqL_prim_dx_n, dqR_prim_dx_n, dqL_prim_dy_n, dqR_prim_dy_n, & - & dqL_prim_dz_n, dqR_prim_dz_n + & dqL_prim_dz_n, dqR_prim_dz_n type(vector_field), dimension(1), intent(inout) :: dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp type(int_bounds_info), intent(in) :: ix, iy, iz @@ -522,8 +520,8 @@ contains $:GPU_UPDATE(device='[iv]') call s_reconstruct_cell_boundary_values_visc(q_prim_qp%vf(iv%beg:iv%end), qL_prim_rsx_vf, qL_prim_rsy_vf, & - & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, i, & - & qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), ix, iy, iz) + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, i, qL_prim(i)%vf(iv%beg:iv%end), & + & qR_prim(i)%vf(iv%beg:iv%end), ix, iy, iz) end do if (weno_Re_flux) then @@ -532,16 +530,13 @@ contains do i = 1, num_dims if (i == 1) then call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & - & dq_prim_dx_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dx, m, & - & buff_size) + & dq_prim_dx_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dx, m, buff_size) else if (i == 2) then call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & - & dq_prim_dy_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dy, n, & - & buff_size) + & dq_prim_dy_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dy, n, buff_size) else call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & - & dq_prim_dz_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dz, p, & - & buff_size) + & dq_prim_dz_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dz, p, buff_size) end if end do else ! Compute velocity gradient at cell centers using finite differences @@ -560,7 +555,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dx_n(1)%vf(i)%sf(j, k, l) = (q_prim_qp%vf(i)%sf(j, k, l) - q_prim_qp%vf(i)%sf(j - 1, k, & - & l))/(x_cc(j) - x_cc(j - 1)) + & l))/(x_cc(j) - x_cc(j - 1)) end do end do end do @@ -574,7 +569,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dx_n(1)%vf(i)%sf(j, k, l) = (q_prim_qp%vf(i)%sf(j + 1, k, l) - q_prim_qp%vf(i)%sf(j, k, & - & l))/(x_cc(j + 1) - x_cc(j)) + & l))/(x_cc(j + 1) - x_cc(j)) end do end do end do @@ -590,7 +585,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dy_n(2)%vf(i)%sf(k, j, l) = (q_prim_qp%vf(i)%sf(k, j, l) - q_prim_qp%vf(i)%sf(k, & - & j - 1, l))/(y_cc(j) - y_cc(j - 1)) + & j - 1, l))/(y_cc(j) - y_cc(j - 1)) end do end do end do @@ -604,7 +599,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dy_n(2)%vf(i)%sf(k, j, l) = (q_prim_qp%vf(i)%sf(k, j + 1, l) - q_prim_qp%vf(i)%sf(k, & - & j, l))/(y_cc(j + 1) - y_cc(j)) + & j, l))/(y_cc(j + 1) - y_cc(j)) end do end do end do @@ -618,8 +613,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dx_n(1)%vf(i)%sf(k, j, & - & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j - 1, & - & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j - 1, l)) + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j - 1, & + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j - 1, l)) dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) end do @@ -635,8 +630,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dx_n(1)%vf(i)%sf(k, j + 1, & - & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j, & - & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l)) + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j, & + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l)) dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) end do @@ -652,8 +647,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dy_n(2)%vf(i)%sf(j, k, & - & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j - 1, k, & - & l) + dqR_prim_dy_n(2)%vf(i)%sf(j - 1, k, l)) + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j - 1, k, & + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j - 1, k, l)) dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) end do @@ -669,8 +664,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dy_n(2)%vf(i)%sf(j + 1, k, & - & l) + dqR_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j, k, & - & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l)) + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j, k, & + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l)) dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) end do @@ -689,7 +684,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dz_n(3)%vf(i)%sf(k, l, j) = (q_prim_qp%vf(i)%sf(k, l, j) - q_prim_qp%vf(i)%sf(k, & - & l, j - 1))/(z_cc(j) - z_cc(j - 1)) + & l, j - 1))/(z_cc(j) - z_cc(j - 1)) end do end do end do @@ -703,7 +698,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dz_n(3)%vf(i)%sf(k, l, j) = (q_prim_qp%vf(i)%sf(k, l, & - & j + 1) - q_prim_qp%vf(i)%sf(k, l, j))/(z_cc(j + 1) - z_cc(j)) + & j + 1) - q_prim_qp%vf(i)%sf(k, l, j))/(z_cc(j + 1) - z_cc(j)) end do end do end do @@ -717,9 +712,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dz_n(3)%vf(i)%sf(j, k, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, & - & l) + dqL_prim_dz_n(3)%vf(i)%sf(j - 1, k, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(j - 1, k, l)) + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, l) + dqL_prim_dz_n(3)%vf(i)%sf(j - 1, k, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j - 1, k, l)) dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) end do @@ -735,9 +729,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dz_n(3)%vf(i)%sf(j + 1, k, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(j + 1, k, & - & l) + dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, & - & l)) + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j + 1, k, l) + dqL_prim_dz_n(3)%vf(i)%sf(j, k, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, l)) dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) end do @@ -753,8 +746,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dz_n(3)%vf(i)%sf(k, j, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l) + dqL_prim_dz_n(3)%vf(i)%sf(k, & - & j - 1, l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j - 1, l)) + & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l) + dqL_prim_dz_n(3)%vf(i)%sf(k, j - 1, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j - 1, l)) dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) end do @@ -770,9 +763,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dz_n(3)%vf(i)%sf(k, j + 1, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j + 1, & - & l) + dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, & - & l)) + & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j + 1, l) + dqL_prim_dz_n(3)%vf(i)%sf(k, j, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l)) dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) end do @@ -788,8 +780,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dy_n(2)%vf(i)%sf(k, l, & - & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & - & j - 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j - 1)) + & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & + & j - 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j - 1)) dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) end do @@ -805,9 +797,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dy_n(2)%vf(i)%sf(k, l, & - & j + 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, & - & j + 1) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & - & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j)) + & j + 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j + 1) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & + & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j)) dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) end do @@ -822,8 +813,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dx_n(1)%vf(i)%sf(k, l, & - & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & - & j - 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j - 1)) + & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & + & j - 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j - 1)) dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) end do @@ -838,9 +829,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dx_n(1)%vf(i)%sf(k, l, & - & j + 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, & - & j + 1) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & - & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j)) + & j + 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j + 1) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & + & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j)) dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) end do @@ -851,33 +841,34 @@ contains do i = iv%beg, iv%end call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dy_qp(1)%vf(i), & - & dq_prim_dz_qp(1)%vf(i)) + & dq_prim_dz_qp(1)%vf(i)) end do #:endif else do i = iv%beg, iv%end call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dy_qp(1)%vf(i), & - & dq_prim_dy_qp(1)%vf(i)) + & dq_prim_dy_qp(1)%vf(i)) end do end if else do i = iv%beg, iv%end call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dx_qp(1)%vf(i), & - & dq_prim_dx_qp(1)%vf(i)) + & dq_prim_dx_qp(1)%vf(i)) end do end if end if end subroutine s_get_viscous + !> @brief Reconstructs left and right cell-boundary values of viscous primitive variables using WENO or MUSCL. subroutine s_reconstruct_cell_boundary_values_visc(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & - & vR_prim_vf, ix, iy, iz) + & vR_prim_vf, ix, iy, iz) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & - & vR_y, vR_z + & vR_y, vR_z integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz integer :: recon_dir !< Coordinate direction of the WENO reconstruction @@ -905,17 +896,16 @@ contains if (n > 0) then if (p > 0) then call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & - & :, iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:, & + & iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & - & recon_dir, is1_viscous, is2_viscous, is3_viscous) + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, & + & is1_viscous, is2_viscous, is3_viscous) end if else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & - & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & - & is3_viscous) + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, is3_viscous) end if end if #:endfor @@ -965,12 +955,13 @@ contains end if end if end subroutine s_reconstruct_cell_boundary_values_visc + !> @brief Reconstructs left and right cell-boundary values of viscous primitive variable derivatives using WENO or MUSCL. subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & - & vR_prim_vf, ix, iy, iz) + & vR_prim_vf, ix, iy, iz) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & - & vR_y, vR_z + & vR_y, vR_z type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf type(int_bounds_info), intent(in) :: ix, iy, iz integer, intent(in) :: norm_dir @@ -997,18 +988,17 @@ contains if (n > 0) then if (p > 0) then call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & - & :, iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:, & + & iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & - & recon_dir, is1_viscous, is2_viscous, is3_viscous) + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, & + & is1_viscous, is2_viscous, is3_viscous) end if else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & - & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & - & is3_viscous) + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, is3_viscous) end if end if #:endfor @@ -1058,6 +1048,7 @@ contains end if end if end subroutine s_reconstruct_cell_boundary_values_visc_deriv + !> The purpose of this subroutine is to employ the inputted left and right cell-boundary integral-averaged variables to compute !! the relevant cell-average first-order spatial derivatives in the x-, y- or z-direction by means of the scalar divergence !! theorem. @@ -1104,7 +1095,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(j))*(wa_flg*vL_vf(i)%sf(j + 1, k, & - & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j - 1, k, l)) + & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j - 1, k, l)) end do end do end do @@ -1128,7 +1119,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(k))*(wa_flg*vL_vf(i)%sf(j, k + 1, & - & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k - 1, l)) + & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k - 1, l)) end do end do end do @@ -1153,7 +1144,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(l))*(wa_flg*vL_vf(i)%sf(j, k, & - & l + 1) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k, l - 1)) + & l + 1) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k, l - 1)) end do end do end do @@ -1162,6 +1153,7 @@ contains end if ! END: First-Order Spatial Derivatives in z-direction end subroutine s_apply_scalar_divergence_theorem + !> Computes the scalar gradient fields via finite differences !! @param var Variable to compute derivative of !! @param grad_x First coordinate direction component of the derivative @@ -1230,9 +1222,9 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end grad_x%sf(idwbuff(1)%beg, k, l) = (-3._wp*var%sf(idwbuff(1)%beg, k, l) + 4._wp*var%sf(idwbuff(1)%beg + 1, k, & - & l) - var%sf(idwbuff(1)%beg + 2, k, l))/(x_cc(idwbuff(1)%beg + 2) - x_cc(idwbuff(1)%beg)) + & l) - var%sf(idwbuff(1)%beg + 2, k, l))/(x_cc(idwbuff(1)%beg + 2) - x_cc(idwbuff(1)%beg)) grad_x%sf(idwbuff(1)%end, k, l) = (+3._wp*var%sf(idwbuff(1)%end, k, l) - 4._wp*var%sf(idwbuff(1)%end - 1, k, & - & l) + var%sf(idwbuff(1)%end - 2, k, l))/(x_cc(idwbuff(1)%end) - x_cc(idwbuff(1)%end - 2)) + & l) + var%sf(idwbuff(1)%end - 2, k, l))/(x_cc(idwbuff(1)%end) - x_cc(idwbuff(1)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1241,9 +1233,9 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_y%sf(j, idwbuff(2)%beg, l) = (-3._wp*var%sf(j, idwbuff(2)%beg, l) + 4._wp*var%sf(j, idwbuff(2)%beg + 1, & - & l) - var%sf(j, idwbuff(2)%beg + 2, l))/(y_cc(idwbuff(2)%beg + 2) - y_cc(idwbuff(2)%beg)) + & l) - var%sf(j, idwbuff(2)%beg + 2, l))/(y_cc(idwbuff(2)%beg + 2) - y_cc(idwbuff(2)%beg)) grad_y%sf(j, idwbuff(2)%end, l) = (+3._wp*var%sf(j, idwbuff(2)%end, l) - 4._wp*var%sf(j, idwbuff(2)%end - 1, & - & l) + var%sf(j, idwbuff(2)%end - 2, l))/(y_cc(idwbuff(2)%end) - y_cc(idwbuff(2)%end - 2)) + & l) + var%sf(j, idwbuff(2)%end - 2, l))/(y_cc(idwbuff(2)%end) - y_cc(idwbuff(2)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1252,11 +1244,11 @@ contains do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_z%sf(j, k, idwbuff(3)%beg) = (-3._wp*var%sf(j, k, idwbuff(3)%beg) + 4._wp*var%sf(j, k, & - & idwbuff(3)%beg + 1) - var%sf(j, k, & - & idwbuff(3)%beg + 2))/(z_cc(idwbuff(3)%beg + 2) - z_cc(is3_viscous%beg)) + & idwbuff(3)%beg + 1) - var%sf(j, k, & + & idwbuff(3)%beg + 2))/(z_cc(idwbuff(3)%beg + 2) - z_cc(is3_viscous%beg)) grad_z%sf(j, k, idwbuff(3)%end) = (+3._wp*var%sf(j, k, idwbuff(3)%end) - 4._wp*var%sf(j, k, & - & idwbuff(3)%end - 1) + var%sf(j, k, & - & idwbuff(3)%end - 2))/(z_cc(idwbuff(3)%end) - z_cc(idwbuff(3)%end - 2)) + & idwbuff(3)%end - 1) + var%sf(j, k, & + & idwbuff(3)%end - 2))/(z_cc(idwbuff(3)%end) - z_cc(idwbuff(3)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1277,7 +1269,7 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end grad_x%sf(m, k, l) = (3._wp*var%sf(m, k, l) - 4._wp*var%sf(m - 1, k, l) + var%sf(m - 2, k, & - & l))/(x_cc(m) - x_cc(m - 2)) + & l))/(x_cc(m) - x_cc(m - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1297,7 +1289,7 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_y%sf(j, n, l) = (3._wp*var%sf(j, n, l) - 4._wp*var%sf(j, n - 1, l) + var%sf(j, n - 2, & - & l))/(y_cc(n) - y_cc(n - 2)) + & l))/(y_cc(n) - y_cc(n - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1308,7 +1300,7 @@ contains do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_z%sf(j, k, 0) = (-3._wp*var%sf(j, k, 0) + 4._wp*var%sf(j, k, 1) - var%sf(j, k, & - & 2))/(z_cc(2) - z_cc(0)) + & 2))/(z_cc(2) - z_cc(0)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1318,7 +1310,7 @@ contains do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_z%sf(j, k, p) = (3._wp*var%sf(j, k, p) - 4._wp*var%sf(j, k, p - 1) + var%sf(j, k, & - & p - 2))/(z_cc(p) - z_cc(p - 2)) + & p - 2))/(z_cc(p) - z_cc(p - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1326,6 +1318,7 @@ contains end if end if end subroutine s_compute_fd_gradient + !> @brief Computes the viscous stress tensor at a single grid cell using finite-difference velocity gradients. subroutine s_compute_viscous_stress_tensor(viscous_stress_tensor, q_prim_vf, dynamic_viscosity, i, j, k) $:GPU_ROUTINE(parallelism='[seq]') @@ -1354,12 +1347,12 @@ contains ! compute the velocity gradient tensor do l = 1, num_dims velocity_gradient_tensor(l, 1) = (q_prim_vf(momxb + l - 1)%sf(i + 1, j, k) - q_prim_vf(momxb + l - 1)%sf(i - 1, j, & - & k))/(2._wp*dx(1)) + & k))/(2._wp*dx(1)) velocity_gradient_tensor(l, 2) = (q_prim_vf(momxb + l - 1)%sf(i, j + 1, k) - q_prim_vf(momxb + l - 1)%sf(i, j - 1, & - & k))/(2._wp*dx(2)) + & k))/(2._wp*dx(2)) if (num_dims == 3) then velocity_gradient_tensor(l, 3) = (q_prim_vf(momxb + l - 1)%sf(i, j, k + 1) - q_prim_vf(momxb + l - 1)%sf(i, j, & - & k - 1))/(2._wp*dx(3)) + & k - 1))/(2._wp*dx(3)) end if end do @@ -1388,6 +1381,7 @@ contains end do end if end subroutine s_compute_viscous_stress_tensor + !> @brief Deallocates the viscous Reynolds number arrays. impure subroutine s_finalize_viscous_module() @:DEALLOCATE(Res_viscous) diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 15bf9c966a..1963c02a6c 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -7,15 +7,12 @@ !> @brief WENO/WENO-Z/TENO reconstruction with optional monotonicity-preserving bounds and mapped weights module m_weno use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion !< State variables type conversion procedures ! $:USE_GPU_MODULE() use m_mpi_proxy - use m_muscl !< For Interface Compression private; public :: s_initialize_weno_module, s_initialize_weno, s_finalize_weno_module, s_weno @@ -167,6 +164,7 @@ contains @:ALLOCATE(v_rs_ws_z(is3_weno%beg:is3_weno%end, is2_weno%beg:is2_weno%end, is1_weno%beg:is1_weno%end, 1:sys_size)) end subroutine s_initialize_weno_module + !> The purpose of this subroutine is to compute the grid dependent coefficients of the WENO polynomials, ideal weights and !! smoothness indicators, provided the order, the coordinate direction and the location of the WENO reconstruction. !! @param weno_dir Coordinate direction of the WENO reconstruction @@ -179,7 +177,7 @@ contains !! Cell-boundary locations in the s-direction type(int_bounds_info) :: bc_s !< Boundary conditions (BC) in the s-direction - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil @@ -236,108 +234,107 @@ contains else if (weno_order == 5) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 0) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i) - s_cb(i & - & + 3))*(s_cb(i + 3) - s_cb(i + 1))) + & 0) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i) - s_cb(i + 3))*(s_cb(i + 3) & + & - s_cb(i + 1))) poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 0) = ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) & - & - s_cb(i + 2))*(s_cb(i + 2) - s_cb(i))) + & 0) = ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) - s_cb(i + 2))*(s_cb(i + 2) & + & - s_cb(i))) poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i - 1) & - & - s_cb(i + 1))*(s_cb(i - 1) - s_cb(i + 2))) + & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i - 1) & + & - s_cb(i + 2))) poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) & - & - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))) + & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i))*(s_cb(i - 2) & + & - s_cb(i + 1))) poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 0) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i) - s_cb(i + 3)) & - & *(s_cb(i + 3) - s_cb(i + 1))) + & 0) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i) - s_cb(i + 3))*(s_cb(i + 3) & + & - s_cb(i + 1))) poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 0) = ((s_cb(i) - s_cb(i - 1))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 1) - s_cb(i & - & + 2))*(s_cb(i) - s_cb(i + 2))) + & 0) = ((s_cb(i) - s_cb(i - 1))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 1) - s_cb(i + 2))*(s_cb(i) & + & - s_cb(i + 2))) poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 1) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i - 1) - s_cb(i & - & + 1))*(s_cb(i - 1) - s_cb(i + 2))) + & 1) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i - 1) & + & - s_cb(i + 2))) poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 1) = ((s_cb(i - 1) - s_cb(i))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 2) - s_cb(i)) & - & *(s_cb(i - 2) - s_cb(i + 1))) + & 1) = ((s_cb(i - 1) - s_cb(i))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 2) - s_cb(i))*(s_cb(i - 2) & + & - s_cb(i + 1))) poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i) - s_cb(i & - & + 2))*(s_cb(i) - s_cb(i + 3)))*((s_cb(i) - s_cb(i + 1))) + & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i) - s_cb(i + 2))*(s_cb(i) & + & - s_cb(i + 3)))*((s_cb(i) - s_cb(i + 1))) poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 0) = ((s_cb(i - 2) - s_cb(i + 1)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 1) & - & - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 2)))*((s_cb(i + 1) - s_cb(i))) + & 0) = ((s_cb(i - 2) - s_cb(i + 1)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 1) - s_cb(i + 1)) & + & *(s_cb(i + 1) - s_cb(i - 2)))*((s_cb(i + 1) - s_cb(i))) poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i) - s_cb(i + 3)))/((s_cb(i) - s_cb(i + 2)) & - & *(s_cb(i) - s_cb(i + 3)))*((s_cb(i + 1) - s_cb(i))) + & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i) - s_cb(i + 3)))/((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i & + & + 3)))*((s_cb(i + 1) - s_cb(i))) poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 0) = ((s_cb(i - 2) - s_cb(i)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 2) & - & - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))*((s_cb(i) - s_cb(i + 1))) + & 0) = ((s_cb(i - 2) - s_cb(i)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i & + & + 1) - s_cb(i - 1)))*((s_cb(i) - s_cb(i + 1))) d_cbR_${XYZ}$ (0, & - & i + 1) = ((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) & - & - s_cb(i + 3))*(s_cb(i + 3) - s_cb(i - 1))) + & i + 1) = ((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i + 3)) & + & *(s_cb(i + 3) - s_cb(i - 1))) d_cbR_${XYZ}$ (2, & - & i + 1) = ((s_cb(i + 1) - s_cb(i + 2))*(s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i - 2) & - & - s_cb(i + 2))*(s_cb(i - 2) - s_cb(i + 3))) + & i + 1) = ((s_cb(i + 1) - s_cb(i + 2))*(s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i - 2) - s_cb(i + 2)) & + & *(s_cb(i - 2) - s_cb(i + 3))) d_cbL_${XYZ}$ (0, & - & i + 1) = ((s_cb(i - 2) - s_cb(i))*(s_cb(i) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i + 3)) & - & *(s_cb(i + 3) - s_cb(i - 1))) + & i + 1) = ((s_cb(i - 2) - s_cb(i))*(s_cb(i) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i + 3))*(s_cb(i + 3) & + & - s_cb(i - 1))) d_cbL_${XYZ}$ (2, & - & i + 1) = ((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3)))/((s_cb(i - 2) - s_cb(i + 2)) & - & *(s_cb(i - 2) - s_cb(i + 3))) + & i + 1) = ((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3)))/((s_cb(i - 2) - s_cb(i + 2))*(s_cb(i - 2) & + & - s_cb(i + 3))) d_cbR_${XYZ}$ (1, i + 1) = 1._wp - d_cbR_${XYZ}$ (0, i + 1) - d_cbR_${XYZ}$ (2, i + 1) d_cbL_${XYZ}$ (1, i + 1) = 1._wp - d_cbL_${XYZ}$ (0, i + 1) - d_cbL_${XYZ}$ (2, i + 1) beta_coef_${XYZ}$ (i + 1, 0, & - & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & - & + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1)) & - & **2._wp)/((s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 1) - s_cb(i + 3))**2._wp) + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i + 1) & + & - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2._wp)/((s_cb(i) - s_cb(i + 3) & + & )**2._wp*(s_cb(i + 1) - s_cb(i + 3))**2._wp) beta_coef_${XYZ}$ (i + 1, 0, & - & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp & - & - (s_cb(i + 1) - s_cb(i))*(s_cb(i + 3) - s_cb(i + 1)) + 2._wp*(s_cb(i + 2) - s_cb(i)) & - & *((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))))/((s_cb(i) - s_cb(i + 2)) & - & *(s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 3) - s_cb(i + 1))) + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp - (s_cb(i + 1) & + & - s_cb(i))*(s_cb(i + 3) - s_cb(i + 1)) + 2._wp*(s_cb(i + 2) - s_cb(i))*((s_cb(i + 2) - s_cb(i)) & + & + (s_cb(i + 3) - s_cb(i + 1))))/((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 3) & + & - s_cb(i + 1))) beta_coef_${XYZ}$ (i + 1, 0, & - & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & - & + (s_cb(i + 1) - s_cb(i))*((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))) & - & + ((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1)))**2._wp)/((s_cb(i) - s_cb(i & - & + 2))**2._wp*(s_cb(i) - s_cb(i + 3))**2._wp) + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i + 1) & + & - s_cb(i))*((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))) + ((s_cb(i + 2) - s_cb(i)) & + & + (s_cb(i + 3) - s_cb(i + 1)))**2._wp)/((s_cb(i) - s_cb(i + 2))**2._wp*(s_cb(i) - s_cb(i + 3))**2._wp) beta_coef_${XYZ}$ (i + 1, 1, & - & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & - & + (s_cb(i) - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i))) & - & /((s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i) - s_cb(i + 2))**2._wp) + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i) & + & - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) - s_cb(i + 2) & + & )**2._wp*(s_cb(i) - s_cb(i + 2))**2._wp) beta_coef_${XYZ}$ (i + 1, 1, & - & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*((s_cb(i) - s_cb(i + 1))*((s_cb(i) & - & - s_cb(i - 1)) + 20._wp*(s_cb(i + 1) - s_cb(i))) + (2._wp*(s_cb(i) - s_cb(i - 1)) & - & + (s_cb(i + 1) - s_cb(i)))*(s_cb(i + 2) - s_cb(i)))/((s_cb(i + 1) - s_cb(i - 1)) & - & *(s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i + 2) - s_cb(i))) + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*((s_cb(i) - s_cb(i + 1))*((s_cb(i) - s_cb(i - 1)) & + & + 20._wp*(s_cb(i + 1) - s_cb(i))) + (2._wp*(s_cb(i) - s_cb(i - 1)) + (s_cb(i + 1) - s_cb(i))) & + & *(s_cb(i + 2) - s_cb(i)))/((s_cb(i + 1) - s_cb(i - 1))*(s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i & + & + 2) - s_cb(i))) beta_coef_${XYZ}$ (i + 1, 1, & - & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & - & + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1)) & - & **2._wp)/((s_cb(i - 1) - s_cb(i + 1))**2._wp*(s_cb(i - 1) - s_cb(i + 2))**2._wp) + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i + 1) & + & - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2._wp)/((s_cb(i - 1) - s_cb(i & + & + 1))**2._wp*(s_cb(i - 1) - s_cb(i + 2))**2._wp) beta_coef_${XYZ}$ (i + 1, 2, & - & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(12._wp*(s_cb(i + 1) - s_cb(i))**2._wp & - & + ((s_cb(i) - s_cb(i - 2)) + (s_cb(i) - s_cb(i - 1)))**2._wp + 3._wp*((s_cb(i) & - & - s_cb(i - 2)) + (s_cb(i) - s_cb(i - 1)))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) & - & - s_cb(i + 1))**2._wp*(s_cb(i - 1) - s_cb(i + 1))**2._wp) + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(12._wp*(s_cb(i + 1) - s_cb(i))**2._wp + ((s_cb(i) & + & - s_cb(i - 2)) + (s_cb(i) - s_cb(i - 1)))**2._wp + 3._wp*((s_cb(i) - s_cb(i - 2)) + (s_cb(i) & + & - s_cb(i - 1)))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i - 1) - s_cb(i & + & + 1))**2._wp) beta_coef_${XYZ}$ (i + 1, 2, & - & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp & - & + ((s_cb(i) - s_cb(i - 2))*(s_cb(i) - s_cb(i + 1))) + 2._wp*(s_cb(i + 1) - s_cb(i & - & - 1))*((s_cb(i) - s_cb(i - 2)) + (s_cb(i + 1) - s_cb(i - 1))))/((s_cb(i - 2) & - & - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i + 1) - s_cb(i - 1))) + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp + ((s_cb(i) & + & - s_cb(i - 2))*(s_cb(i) - s_cb(i + 1))) + 2._wp*(s_cb(i + 1) - s_cb(i - 1))*((s_cb(i) - s_cb(i - 2)) & + & + (s_cb(i + 1) - s_cb(i - 1))))/((s_cb(i - 2) - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i & + & + 1) - s_cb(i - 1))) beta_coef_${XYZ}$ (i + 1, 2, & - & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & - & + (s_cb(i) - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i))) & - & /((s_cb(i - 2) - s_cb(i))**2._wp*(s_cb(i - 2) - s_cb(i + 1))**2._wp) + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i) & + & - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) - s_cb(i)) & + & **2._wp*(s_cb(i - 2) - s_cb(i + 1))**2._wp) end do ! Modifying the ideal weights coefficients in the neighborhood @@ -354,9 +351,9 @@ contains if (bc_s%end == BC_RIEMANN_EXTRAP) then d_cbR_${XYZ}$ (0, s - 1) = 0._wp; d_cbR_${XYZ}$ (:, s - 1) = d_cbR_${XYZ}$ (:, & - & s - 1)/sum(d_cbR_${XYZ}$ (:, s - 1)) + & s - 1)/sum(d_cbR_${XYZ}$ (:, s - 1)) d_cbL_${XYZ}$ (0, s - 1) = 0._wp; d_cbL_${XYZ}$ (:, s - 1) = d_cbL_${XYZ}$ (:, & - & s - 1)/sum(d_cbL_${XYZ}$ (:, s - 1)) + & s - 1)/sum(d_cbL_${XYZ}$ (:, s - 1)) d_cbR_${XYZ}$ (0:1, s) = 0._wp; d_cbR_${XYZ}$ (2, s) = 1._wp d_cbL_${XYZ}$ (0:1, s) = 0._wp; d_cbL_${XYZ}$ (2, s) = 1._wp end if @@ -385,450 +382,394 @@ contains w = s_cb(i - 3:i + 4) - s_cb(i) ! Offset using s_cb(i) to reduce floating point error d_cbR_${XYZ}$ (0, & - & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & - & *(w(1) - w(8))) !& + & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))) & + & !& d_cbR_${XYZ}$ (1, & - & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1) & - & *w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7) & - & *w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7)) & - & *(w(2) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1)*w(7) - w(2) & + & *w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7)*w(8) + w(1)**2 + w(2) & + & **2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))) !& d_cbR_${XYZ}$ (2, & - & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2) & - & *w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7) & - & *w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8)) & - & *(w(3) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2)*w(3) - w(1) & + & *w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7)*w(8) + w(7)**2 + w(8) & + & **2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))*(w(3) - w(8))) !& d_cbR_${XYZ}$ (3, & - & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8)) & - & *(w(3) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8))*(w(3) - w(8))) & + & !& w = s_cb(i + 4:i - 3:-1) - s_cb(i) d_cbL_${XYZ}$ (0, & - & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8)) & - & *(w(3) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8))*(w(3) - w(8))) & + & !& d_cbL_${XYZ}$ (1, & - & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2) & - & *w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7) & - & *w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8)) & - & *(w(3) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2)*w(3) - w(1) & + & *w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7)*w(8) + w(7)**2 + w(8) & + & **2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))*(w(3) - w(8))) !& d_cbL_${XYZ}$ (2, & - & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1) & - & *w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7) & - & *w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7)) & - & *(w(2) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1)*w(7) - w(2) & + & *w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7)*w(8) + w(1)**2 + w(2) & + & **2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))) !& d_cbL_${XYZ}$ (3, & - & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & - & *(w(1) - w(8))) !& + & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))) & + & !& ! Note: Left has the reversed order of both points and coefficients compared to the right y = s_cb(i + 1:i + 4) - s_cb(i:i + 3) poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 0) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & 0) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) & - & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & - & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) + 3*y(3)**2 + 3*y(3)*y(4) & + & + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4)) & + & *(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 2) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & - & + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) & - & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & 2) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 4*y(2)*y(3) + 2*y(4) & + & *y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i:i + 3) - s_cb(i - 1:i + 2) poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 0) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & 0) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) & + & !& poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) & - & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & - & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 3*y(3) & + & *y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 2) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & 2) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i - 1:i + 2) - s_cb(i - 2:i + 1) poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 0) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 0) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) & + & + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & - & + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) & - & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 6*y(2)*y(3) & + & + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 2) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & 2) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) & + & !& y = s_cb(i - 2:i + 1) - s_cb(i - 3:i) poly_coef_cbR_${XYZ}$ (i + 1, 3, & - & 0) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 & - & + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) & - & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 0) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 6*y(3)*y(4) + 2*y(1) & + & *y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4) & + & )) !& poly_coef_cbR_${XYZ}$ (i + 1, 3, & - & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) & - & + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2)) & - & /((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))) !& + & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) + 3*y(2)**2 & + & + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2))/((y(2) + y(3))*(y(1) + y(2) & + & + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 3, & - & 2) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) & - & + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & 2) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) & + & + y(3) + y(4))) !& y = s_cb(i + 1:i - 2:-1) - s_cb(i:i - 3:-1) poly_coef_cbL_${XYZ}$ (i + 1, 3, & - & 2) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & 2) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 3, & - & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) & - & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & - & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) + 3*y(3)**2 + 3*y(3)*y(4) & + & + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4)) & + & *(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 3, & - & 0) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & - & + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) & - & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & 0) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 4*y(2)*y(3) + 2*y(4) & + & *y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i + 2:i - 1:-1) - s_cb(i + 1:i - 2:-1) poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 2) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & 2) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) & + & !& poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) & - & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & - & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 3*y(3) & + & *y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 0) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & 0) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i + 3:i:-1) - s_cb(i + 2:i - 1:-1) poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 2) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 2) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) & + & + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & - & + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) & - & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 6*y(2)*y(3) & + & + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 0) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & 0) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) & + & !& y = s_cb(i + 4:i + 1:-1) - s_cb(i + 3:i:-1) poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 2) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 & - & + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) & - & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 2) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 6*y(3)*y(4) + 2*y(1) & + & *y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4) & + & )) !& poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) & - & + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2)) & - & /((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))) !& + & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) + 3*y(2)**2 & + & + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2))/((y(2) + y(3))*(y(1) + y(2) & + & + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 0) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) & - & + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & 0) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) & + & + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1,:,:) = -poly_coef_cbL_${XYZ}$ (i + 1,:,:) ! Note: negative sign as the direction of taking the difference (dvd) is reversed y = s_cb(i - 2:i + 1) - s_cb(i - 3:i) beta_coef_${XYZ}$ (i + 1, 3, & - & 0) = (4*y(4)**2*(5*y(1)**2*y(2)**2 + 20*y(1)**2*y(2)*y(3) + 15*y(1)**2*y(2)*y(4) & - & + 20*y(1)**2*y(3)**2 + 30*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 10*y(1)*y(2) & - & **3 + 60*y(1)*y(2)**2*y(3) + 45*y(1)*y(2)**2*y(4) + 110*y(1)*y(2)*y(3)**2 & - & + 165*y(1)*y(2)*y(3)*y(4) + 260*y(1)*y(2)*y(4)**2 + 60*y(1)*y(3)**3 + 135*y(1) & - & *y(3)**2*y(4) + 400*y(1)*y(3)*y(4)**2 + 225*y(1)*y(4)**3 + 5*y(2)**4 + 40*y(2) & - & **3*y(3) + 30*y(2)**3*y(4) + 110*y(2)**2*y(3)**2 + 165*y(2)**2*y(3)*y(4) & - & + 260*y(2)**2*y(4)**2 + 120*y(2)*y(3)**3 + 270*y(2)*y(3)**2*y(4) + 800*y(2)*y(3) & - & *y(4)**2 + 450*y(2)*y(4)**3 + 45*y(3)**4 + 135*y(3)**3*y(4) + 600*y(3)**2*y(4) & - & **2 + 675*y(3)*y(4)**3 + 996*y(4)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4)) & - & **2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 0) = (4*y(4)**2*(5*y(1)**2*y(2)**2 + 20*y(1)**2*y(2)*y(3) + 15*y(1)**2*y(2)*y(4) + 20*y(1) & + & **2*y(3)**2 + 30*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 10*y(1)*y(2)**3 + 60*y(1)*y(2)**2*y(3) & + & + 45*y(1)*y(2)**2*y(4) + 110*y(1)*y(2)*y(3)**2 + 165*y(1)*y(2)*y(3)*y(4) + 260*y(1)*y(2)*y(4) & + & **2 + 60*y(1)*y(3)**3 + 135*y(1)*y(3)**2*y(4) + 400*y(1)*y(3)*y(4)**2 + 225*y(1)*y(4)**3 & + & + 5*y(2)**4 + 40*y(2)**3*y(3) + 30*y(2)**3*y(4) + 110*y(2)**2*y(3)**2 + 165*y(2)**2*y(3)*y(4) & + & + 260*y(2)**2*y(4)**2 + 120*y(2)*y(3)**3 + 270*y(2)*y(3)**2*y(4) + 800*y(2)*y(3)*y(4)**2 & + & + 450*y(2)*y(4)**3 + 45*y(3)**4 + 135*y(3)**3*y(4) + 600*y(3)**2*y(4)**2 + 675*y(3)*y(4)**3 & + & + 996*y(4)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 1) = -(4*y(4)**2*(10*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1)**3*y(3) & - & **2 + 25*y(1)**3*y(3)*y(4) + 105*y(1)**3*y(4)**2 + 40*y(1)**2*y(2)**2*y(3) & - & + 20*y(1)**2*y(2)**2*y(4) + 130*y(1)**2*y(2)*y(3)**2 + 155*y(1)**2*y(2)*y(3)*y(4) & - & + 535*y(1)**2*y(2)*y(4)**2 + 90*y(1)**2*y(3)**3 + 165*y(1)**2*y(3)**2*y(4) & - & + 790*y(1)**2*y(3)*y(4)**2 + 415*y(1)**2*y(4)**3 + 60*y(1)*y(2)**3*y(3) + 30*y(1) & - & *y(2)**3*y(4) + 270*y(1)*y(2)**2*y(3)**2 + 315*y(1)*y(2)**2*y(3)*y(4) + 975*y(1) & - & *y(2)**2*y(4)**2 + 360*y(1)*y(2)*y(3)**3 + 645*y(1)*y(2)*y(3)**2*y(4) + 2850*y(1) & - & *y(2)*y(3)*y(4)**2 + 1460*y(1)*y(2)*y(4)**3 + 150*y(1)*y(3)**4 + 360*y(1)*y(3) & - & **3*y(4) + 2000*y(1)*y(3)**2*y(4)**2 + 2005*y(1)*y(3)*y(4)**3 + 2077*y(1)*y(4) & - & **4 + 30*y(2)**4*y(3) + 15*y(2)**4*y(4) + 180*y(2)**3*y(3)**2 + 210*y(2)**3*y(3) & - & *y(4) + 650*y(2)**3*y(4)**2 + 360*y(2)**2*y(3)**3 + 645*y(2)**2*y(3)**2*y(4) & - & + 2850*y(2)**2*y(3)*y(4)**2 + 1460*y(2)**2*y(4)**3 + 300*y(2)*y(3)**4 + 720*y(2) & - & *y(3)**3*y(4) + 4000*y(2)*y(3)**2*y(4)**2 + 4010*y(2)*y(3)*y(4)**3 + 4154*y(2) & - & *y(4)**4 + 90*y(3)**5 + 270*y(3)**4*y(4) + 1800*y(3)**3*y(4)**2 + 2655*y(3) & - & **2*y(4)**3 + 4464*y(3)*y(4)**4 + 1767*y(4)**5))/(5*(y(2) + y(3))*(y(3) + y(4)) & - & *(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 1) = -(4*y(4)**2*(10*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1)**3*y(3)**2 + 25*y(1) & + & **3*y(3)*y(4) + 105*y(1)**3*y(4)**2 + 40*y(1)**2*y(2)**2*y(3) + 20*y(1)**2*y(2)**2*y(4) & + & + 130*y(1)**2*y(2)*y(3)**2 + 155*y(1)**2*y(2)*y(3)*y(4) + 535*y(1)**2*y(2)*y(4)**2 + 90*y(1) & + & **2*y(3)**3 + 165*y(1)**2*y(3)**2*y(4) + 790*y(1)**2*y(3)*y(4)**2 + 415*y(1)**2*y(4)**3 & + & + 60*y(1)*y(2)**3*y(3) + 30*y(1)*y(2)**3*y(4) + 270*y(1)*y(2)**2*y(3)**2 + 315*y(1)*y(2)**2*y(3) & + & *y(4) + 975*y(1)*y(2)**2*y(4)**2 + 360*y(1)*y(2)*y(3)**3 + 645*y(1)*y(2)*y(3)**2*y(4) & + & + 2850*y(1)*y(2)*y(3)*y(4)**2 + 1460*y(1)*y(2)*y(4)**3 + 150*y(1)*y(3)**4 + 360*y(1)*y(3) & + & **3*y(4) + 2000*y(1)*y(3)**2*y(4)**2 + 2005*y(1)*y(3)*y(4)**3 + 2077*y(1)*y(4)**4 + 30*y(2) & + & **4*y(3) + 15*y(2)**4*y(4) + 180*y(2)**3*y(3)**2 + 210*y(2)**3*y(3)*y(4) + 650*y(2)**3*y(4)**2 & + & + 360*y(2)**2*y(3)**3 + 645*y(2)**2*y(3)**2*y(4) + 2850*y(2)**2*y(3)*y(4)**2 + 1460*y(2)**2*y(4) & + & **3 + 300*y(2)*y(3)**4 + 720*y(2)*y(3)**3*y(4) + 4000*y(2)*y(3)**2*y(4)**2 + 4010*y(2)*y(3)*y(4) & + & **3 + 4154*y(2)*y(4)**4 + 90*y(3)**5 + 270*y(3)**4*y(4) + 1800*y(3)**3*y(4)**2 + 2655*y(3) & + & **2*y(4)**3 + 4464*y(3)*y(4)**4 + 1767*y(4)**5))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) & + & + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 2) = (4*y(4)**2*(10*y(2)**3*y(3) + 5*y(2)**3*y(4) + 50*y(2)**2*y(3)**2 + 60*y(2) & - & **2*y(3)*y(4) + 10*y(1)*y(2)**2*y(3) + 215*y(2)**2*y(4)**2 + 5*y(1)*y(2)**2*y(4) & - & + 70*y(2)*y(3)**3 + 130*y(2)*y(3)**2*y(4) + 30*y(1)*y(2)*y(3)**2 + 775*y(2)*y(3) & - & *y(4)**2 + 35*y(1)*y(2)*y(3)*y(4) + 415*y(2)*y(4)**3 + 110*y(1)*y(2)*y(4)**2 & - & + 30*y(3)**4 + 75*y(3)**3*y(4) + 20*y(1)*y(3)**3 + 665*y(3)**2*y(4)**2 + 35*y(1) & - & *y(3)**2*y(4) + 725*y(3)*y(4)**3 + 220*y(1)*y(3)*y(4)**2 + 1767*y(4)**4 & - & + 105*y(1)*y(4)**3))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & - & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & 2) = (4*y(4)**2*(10*y(2)**3*y(3) + 5*y(2)**3*y(4) + 50*y(2)**2*y(3)**2 + 60*y(2)**2*y(3)*y(4) & + & + 10*y(1)*y(2)**2*y(3) + 215*y(2)**2*y(4)**2 + 5*y(1)*y(2)**2*y(4) + 70*y(2)*y(3)**3 + 130*y(2) & + & *y(3)**2*y(4) + 30*y(1)*y(2)*y(3)**2 + 775*y(2)*y(3)*y(4)**2 + 35*y(1)*y(2)*y(3)*y(4) + 415*y(2) & + & *y(4)**3 + 110*y(1)*y(2)*y(4)**2 + 30*y(3)**4 + 75*y(3)**3*y(4) + 20*y(1)*y(3)**3 + 665*y(3) & + & **2*y(4)**2 + 35*y(1)*y(3)**2*y(4) + 725*y(3)*y(4)**3 + 220*y(1)*y(3)*y(4)**2 + 1767*y(4)**4 & + & + 105*y(1)*y(4)**3))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4)) & + & *(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 3) = (4*y(4)**2*(5*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 50*y(1)**4*y(4)**2 & - & + 30*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 300*y(1)**3*y(2)*y(4)**2 & - & + 30*y(1)**3*y(3)**3 + 45*y(1)**3*y(3)**2*y(4) + 415*y(1)**3*y(3)*y(4)**2 & - & + 200*y(1)**3*y(4)**3 + 75*y(1)**2*y(2)**2*y(3)**2 + 75*y(1)**2*y(2)**2*y(3)*y(4) & - & + 750*y(1)**2*y(2)**2*y(4)**2 + 150*y(1)**2*y(2)*y(3)**3 + 225*y(1)**2*y(2)*y(3) & - & **2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 1000*y(1)**2*y(2)*y(4)**3 + 75*y(1) & - & **2*y(3)**4 + 150*y(1)**2*y(3)**3*y(4) + 1390*y(1)**2*y(3)**2*y(4)**2 + 1315*y(1) & - & **2*y(3)*y(4)**3 + 1081*y(1)**2*y(4)**4 + 90*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2) & - & **3*y(3)*y(4) + 900*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1) & - & *y(2)**2*y(3)**2*y(4) + 3735*y(1)*y(2)**2*y(3)*y(4)**2 + 1800*y(1)*y(2)**2*y(4) & - & **3 + 270*y(1)*y(2)*y(3)**4 + 540*y(1)*y(2)*y(3)**3*y(4) + 5025*y(1)*y(2)*y(3) & - & **2*y(4)**2 + 4755*y(1)*y(2)*y(3)*y(4)**3 + 4224*y(1)*y(2)*y(4)**4 + 90*y(1)*y(3) & - & **5 + 225*y(1)*y(3)**4*y(4) + 2190*y(1)*y(3)**3*y(4)**2 + 3060*y(1)*y(3)**2*y(4) & - & **3 + 4529*y(1)*y(3)*y(4)**4 + 1762*y(1)*y(4)**5 + 45*y(2)**4*y(3)**2 + 45*y(2) & - & **4*y(3)*y(4) + 450*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3) & - & **2*y(4) + 2490*y(2)**3*y(3)*y(4)**2 + 1200*y(2)**3*y(4)**3 + 270*y(2)**2*y(3) & - & **4 + 540*y(2)**2*y(3)**3*y(4) + 5025*y(2)**2*y(3)**2*y(4)**2 + 4755*y(2)**2*y(3) & - & *y(4)**3 + 4224*y(2)**2*y(4)**4 + 180*y(2)*y(3)**5 + 450*y(2)*y(3)**4*y(4) & - & + 4380*y(2)*y(3)**3*y(4)**2 + 6120*y(2)*y(3)**2*y(4)**3 + 9058*y(2)*y(3)*y(4)**4 & - & + 3524*y(2)*y(4)**5 + 45*y(3)**6 + 135*y(3)**5*y(4) + 1395*y(3)**4*y(4)**2 & - & + 2565*y(3)**3*y(4)**3 + 4884*y(3)**2*y(4)**4 + 3624*y(3)*y(4)**5 + 831*y(4)**6)) & - & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & 3) = (4*y(4)**2*(5*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 50*y(1)**4*y(4)**2 + 30*y(1)**3*y(2) & + & *y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 300*y(1)**3*y(2)*y(4)**2 + 30*y(1)**3*y(3)**3 + 45*y(1) & + & **3*y(3)**2*y(4) + 415*y(1)**3*y(3)*y(4)**2 + 200*y(1)**3*y(4)**3 + 75*y(1)**2*y(2)**2*y(3)**2 & + & + 75*y(1)**2*y(2)**2*y(3)*y(4) + 750*y(1)**2*y(2)**2*y(4)**2 + 150*y(1)**2*y(2)*y(3)**3 & + & + 225*y(1)**2*y(2)*y(3)**2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 1000*y(1)**2*y(2)*y(4)**3 & + & + 75*y(1)**2*y(3)**4 + 150*y(1)**2*y(3)**3*y(4) + 1390*y(1)**2*y(3)**2*y(4)**2 + 1315*y(1) & + & **2*y(3)*y(4)**3 + 1081*y(1)**2*y(4)**4 + 90*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2)**3*y(3)*y(4) & + & + 900*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1)*y(2)**2*y(3)**2*y(4) & + & + 3735*y(1)*y(2)**2*y(3)*y(4)**2 + 1800*y(1)*y(2)**2*y(4)**3 + 270*y(1)*y(2)*y(3)**4 + 540*y(1) & + & *y(2)*y(3)**3*y(4) + 5025*y(1)*y(2)*y(3)**2*y(4)**2 + 4755*y(1)*y(2)*y(3)*y(4)**3 + 4224*y(1) & + & *y(2)*y(4)**4 + 90*y(1)*y(3)**5 + 225*y(1)*y(3)**4*y(4) + 2190*y(1)*y(3)**3*y(4)**2 + 3060*y(1) & + & *y(3)**2*y(4)**3 + 4529*y(1)*y(3)*y(4)**4 + 1762*y(1)*y(4)**5 + 45*y(2)**4*y(3)**2 + 45*y(2) & + & **4*y(3)*y(4) + 450*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3)**2*y(4) + 2490*y(2) & + & **3*y(3)*y(4)**2 + 1200*y(2)**3*y(4)**3 + 270*y(2)**2*y(3)**4 + 540*y(2)**2*y(3)**3*y(4) & + & + 5025*y(2)**2*y(3)**2*y(4)**2 + 4755*y(2)**2*y(3)*y(4)**3 + 4224*y(2)**2*y(4)**4 + 180*y(2) & + & *y(3)**5 + 450*y(2)*y(3)**4*y(4) + 4380*y(2)*y(3)**3*y(4)**2 + 6120*y(2)*y(3)**2*y(4)**3 & + & + 9058*y(2)*y(3)*y(4)**4 + 3524*y(2)*y(4)**5 + 45*y(3)**6 + 135*y(3)**5*y(4) + 1395*y(3)**4*y(4) & + & **2 + 2565*y(3)**3*y(4)**3 + 4884*y(3)**2*y(4)**4 + 3624*y(3)*y(4)**5 + 831*y(4)**6))/(5*(y(2) & + & + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 4) = -(4*y(4)**2*(10*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 100*y(1) & - & **2*y(2)*y(4)**2 + 10*y(1)**2*y(3)**3 + 15*y(1)**2*y(3)**2*y(4) + 205*y(1) & - & **2*y(3)*y(4)**2 + 100*y(1)**2*y(4)**3 + 30*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2) & - & **2*y(3)*y(4) + 300*y(1)*y(2)**2*y(4)**2 + 60*y(1)*y(2)*y(3)**3 + 90*y(1)*y(2) & - & *y(3)**2*y(4) + 1030*y(1)*y(2)*y(3)*y(4)**2 + 500*y(1)*y(2)*y(4)**3 + 30*y(1) & - & *y(3)**4 + 60*y(1)*y(3)**3*y(4) + 835*y(1)*y(3)**2*y(4)**2 + 805*y(1)*y(3)*y(4) & - & **3 + 1762*y(1)*y(4)**4 + 30*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 300*y(2) & - & **3*y(4)**2 + 90*y(2)**2*y(3)**3 + 135*y(2)**2*y(3)**2*y(4) + 1445*y(2)**2*y(3) & - & *y(4)**2 + 700*y(2)**2*y(4)**3 + 90*y(2)*y(3)**4 + 180*y(2)*y(3)**3*y(4) & - & + 2205*y(2)*y(3)**2*y(4)**2 + 2115*y(2)*y(3)*y(4)**3 + 3624*y(2)*y(4)**4 & - & + 30*y(3)**5 + 75*y(3)**4*y(4) + 1060*y(3)**3*y(4)**2 + 1515*y(3)**2*y(4)**3 & - & + 3824*y(3)*y(4)**4 + 1662*y(4)**5))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) & - & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & 4) = -(4*y(4)**2*(10*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 100*y(1)**2*y(2)*y(4) & + & **2 + 10*y(1)**2*y(3)**3 + 15*y(1)**2*y(3)**2*y(4) + 205*y(1)**2*y(3)*y(4)**2 + 100*y(1)**2*y(4) & + & **3 + 30*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2)**2*y(3)*y(4) + 300*y(1)*y(2)**2*y(4)**2 + 60*y(1) & + & *y(2)*y(3)**3 + 90*y(1)*y(2)*y(3)**2*y(4) + 1030*y(1)*y(2)*y(3)*y(4)**2 + 500*y(1)*y(2)*y(4)**3 & + & + 30*y(1)*y(3)**4 + 60*y(1)*y(3)**3*y(4) + 835*y(1)*y(3)**2*y(4)**2 + 805*y(1)*y(3)*y(4)**3 & + & + 1762*y(1)*y(4)**4 + 30*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 300*y(2)**3*y(4)**2 + 90*y(2) & + & **2*y(3)**3 + 135*y(2)**2*y(3)**2*y(4) + 1445*y(2)**2*y(3)*y(4)**2 + 700*y(2)**2*y(4)**3 & + & + 90*y(2)*y(3)**4 + 180*y(2)*y(3)**3*y(4) + 2205*y(2)*y(3)**2*y(4)**2 + 2115*y(2)*y(3)*y(4)**3 & + & + 3624*y(2)*y(4)**4 + 30*y(3)**5 + 75*y(3)**4*y(4) + 1060*y(3)**3*y(4)**2 + 1515*y(3)**2*y(4) & + & **3 + 3824*y(3)*y(4)**4 + 1662*y(4)**5))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3)) & + & **2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 5) = (4*y(4)**2*(5*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 & - & + 10*y(2)*y(3)**3 + 15*y(2)*y(3)**2*y(4) + 205*y(2)*y(3)*y(4)**2 + 100*y(2)*y(4) & - & **3 + 5*y(3)**4 + 10*y(3)**3*y(4) + 205*y(3)**2*y(4)**2 + 200*y(3)*y(4)**3 & - & + 831*y(4)**4))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & 5) = (4*y(4)**2*(5*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 & + & + 15*y(2)*y(3)**2*y(4) + 205*y(2)*y(3)*y(4)**2 + 100*y(2)*y(4)**3 + 5*y(3)**4 + 10*y(3)**3*y(4) & + & + 205*y(3)**2*y(4)**2 + 200*y(3)*y(4)**3 + 831*y(4)**4))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3) & + & )**2*(y(1) + y(2) + y(3) + y(4))**2) !& y = s_cb(i - 1:i + 2) - s_cb(i - 2:i + 1) beta_coef_${XYZ}$ (i + 1, 2, & - & 0) = (4*y(3)**2*(5*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 & - & + 10*y(1)*y(2)**3 + 15*y(1)*y(2)**2*y(3) + 205*y(1)*y(2)*y(3)**2 + 100*y(1)*y(3) & - & **3 + 5*y(2)**4 + 10*y(2)**3*y(3) + 205*y(2)**2*y(3)**2 + 200*y(2)*y(3)**3 & - & + 831*y(3)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & 0) = (4*y(3)**2*(5*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 & + & + 15*y(1)*y(2)**2*y(3) + 205*y(1)*y(2)*y(3)**2 + 100*y(1)*y(3)**3 + 5*y(2)**4 + 10*y(2)**3*y(3) & + & + 205*y(2)**2*y(3)**2 + 200*y(2)*y(3)**3 + 831*y(3)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4) & + & )**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 1) = (4*y(3)**2*(5*y(1)**3*y(2)*y(3) + 10*y(1)**3*y(2)*y(4) - 95*y(1)**3*y(3)**2 & - & + 5*y(1)**3*y(3)*y(4) + 20*y(1)**2*y(2)**2*y(3) + 40*y(1)**2*y(2)**2*y(4) & - & - 465*y(1)**2*y(2)*y(3)**2 + 55*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4)**2 & - & - 285*y(1)**2*y(3)**3 + 20*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 & - & + 30*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) - 825*y(1)*y(2)**2*y(3)**2 & - & + 135*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 - 1040*y(1)*y(2)*y(3)**3 & - & + 100*y(1)*y(2)*y(3)**2*y(4) + 35*y(1)*y(2)*y(3)*y(4)**2 - 1847*y(1)*y(3)**4 & - & + 125*y(1)*y(3)**3*y(4) + 110*y(1)*y(3)**2*y(4)**2 + 15*y(2)**4*y(3) + 30*y(2) & - & **4*y(4) - 550*y(2)**3*y(3)**2 + 90*y(2)**3*y(3)*y(4) + 20*y(2)**3*y(4)**2 & - & - 1040*y(2)**2*y(3)**3 + 100*y(2)**2*y(3)**2*y(4) + 35*y(2)**2*y(3)*y(4)**2 & - & - 3694*y(2)*y(3)**4 + 250*y(2)*y(3)**3*y(4) + 220*y(2)*y(3)**2*y(4)**2 & - & - 3219*y(3)**5 - 1452*y(3)**4*y(4) + 105*y(3)**3*y(4)**2))/(5*(y(2) + y(3))*(y(3) & - & + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4)) & - & **2) !& + & 1) = (4*y(3)**2*(5*y(1)**3*y(2)*y(3) + 10*y(1)**3*y(2)*y(4) - 95*y(1)**3*y(3)**2 + 5*y(1) & + & **3*y(3)*y(4) + 20*y(1)**2*y(2)**2*y(3) + 40*y(1)**2*y(2)**2*y(4) - 465*y(1)**2*y(2)*y(3)**2 & + & + 55*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4)**2 - 285*y(1)**2*y(3)**3 + 20*y(1)**2*y(3) & + & **2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 30*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) - 825*y(1)*y(2) & + & **2*y(3)**2 + 135*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 - 1040*y(1)*y(2)*y(3)**3 & + & + 100*y(1)*y(2)*y(3)**2*y(4) + 35*y(1)*y(2)*y(3)*y(4)**2 - 1847*y(1)*y(3)**4 + 125*y(1)*y(3) & + & **3*y(4) + 110*y(1)*y(3)**2*y(4)**2 + 15*y(2)**4*y(3) + 30*y(2)**4*y(4) - 550*y(2)**3*y(3)**2 & + & + 90*y(2)**3*y(3)*y(4) + 20*y(2)**3*y(4)**2 - 1040*y(2)**2*y(3)**3 + 100*y(2)**2*y(3)**2*y(4) & + & + 35*y(2)**2*y(3)*y(4)**2 - 3694*y(2)*y(3)**4 + 250*y(2)*y(3)**3*y(4) + 220*y(2)*y(3)**2*y(4) & + & **2 - 3219*y(3)**5 - 1452*y(3)**4*y(4) + 105*y(3)**3*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4)) & + & *(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 2) = -(4*y(3)**2*(5*y(2)**3*y(3) - 95*y(2)*y(3)**3 - 190*y(2)**2*y(3)**2 & - & + 10*y(2)**3*y(4) + 100*y(3)**3*y(4) - 1562*y(3)**4 - 95*y(1)*y(2)*y(3)**2 & - & + 5*y(1)*y(2)**2*y(3) + 10*y(1)*y(2)**2*y(4) + 100*y(1)*y(3)**2*y(4) + 205*y(2) & - & *y(3)**2*y(4) + 15*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2)) & - & *(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & 2) = -(4*y(3)**2*(5*y(2)**3*y(3) - 95*y(2)*y(3)**3 - 190*y(2)**2*y(3)**2 + 10*y(2)**3*y(4) & + & + 100*y(3)**3*y(4) - 1562*y(3)**4 - 95*y(1)*y(2)*y(3)**2 + 5*y(1)*y(2)**2*y(3) + 10*y(1)*y(2) & + & **2*y(4) + 100*y(1)*y(3)**2*y(4) + 205*y(2)*y(3)**2*y(4) + 15*y(2)**2*y(3)*y(4) + 10*y(1)*y(2) & + & *y(3)*y(4)))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 3) = (4*y(3)**2*(50*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 & - & + 300*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 30*y(1)**3*y(2)*y(4)**2 & - & + 200*y(1)**3*y(3)**3 + 25*y(1)**3*y(3)**2*y(4) + 35*y(1)**3*y(3)*y(4)**2 & - & + 10*y(1)**3*y(4)**3 + 750*y(1)**2*y(2)**2*y(3)**2 + 75*y(1)**2*y(2)**2*y(3)*y(4) & - & + 75*y(1)**2*y(2)**2*y(4)**2 + 1000*y(1)**2*y(2)*y(3)**3 + 125*y(1)**2*y(2)*y(3) & - & **2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 + 50*y(1)**2*y(2)*y(4)**3 + 1081*y(1) & - & **2*y(3)**4 - 50*y(1)**2*y(3)**3*y(4) - 10*y(1)**2*y(3)**2*y(4)**2 + 45*y(1) & - & **2*y(3)*y(4)**3 + 5*y(1)**2*y(4)**4 + 900*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2) & - & **3*y(3)*y(4) + 90*y(1)*y(2)**3*y(4)**2 + 1800*y(1)*y(2)**2*y(3)**3 + 225*y(1) & - & *y(2)**2*y(3)**2*y(4) + 315*y(1)*y(2)**2*y(3)*y(4)**2 + 90*y(1)*y(2)**2*y(4)**3 & - & + 4224*y(1)*y(2)*y(3)**4 - 120*y(1)*y(2)*y(3)**3*y(4) + 25*y(1)*y(2)*y(3)**2*y(4) & - & **2 + 165*y(1)*y(2)*y(3)*y(4)**3 + 20*y(1)*y(2)*y(4)**4 + 3324*y(1)*y(3)**5 & - & + 1407*y(1)*y(3)**4*y(4) - 100*y(1)*y(3)**3*y(4)**2 + 70*y(1)*y(3)**2*y(4)**3 & - & + 15*y(1)*y(3)*y(4)**4 + 450*y(2)**4*y(3)**2 + 45*y(2)**4*y(3)*y(4) + 45*y(2) & - & **4*y(4)**2 + 1200*y(2)**3*y(3)**3 + 150*y(2)**3*y(3)**2*y(4) + 210*y(2)**3*y(3) & - & *y(4)**2 + 60*y(2)**3*y(4)**3 + 4224*y(2)**2*y(3)**4 - 120*y(2)**2*y(3)**3*y(4) & - & + 25*y(2)**2*y(3)**2*y(4)**2 + 165*y(2)**2*y(3)*y(4)**3 + 20*y(2)**2*y(4)**4 & - & + 6648*y(2)*y(3)**5 + 2814*y(2)*y(3)**4*y(4) - 200*y(2)*y(3)**3*y(4)**2 & - & + 140*y(2)*y(3)**2*y(4)**3 + 30*y(2)*y(3)*y(4)**4 + 3174*y(3)**6 + 3039*y(3) & - & **5*y(4) + 771*y(3)**4*y(4)**2 + 135*y(3)**3*y(4)**3 + 60*y(3)**2*y(4)**4)) & - & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & 3) = (4*y(3)**2*(50*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 300*y(1)**3*y(2) & + & *y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 30*y(1)**3*y(2)*y(4)**2 + 200*y(1)**3*y(3)**3 + 25*y(1) & + & **3*y(3)**2*y(4) + 35*y(1)**3*y(3)*y(4)**2 + 10*y(1)**3*y(4)**3 + 750*y(1)**2*y(2)**2*y(3)**2 & + & + 75*y(1)**2*y(2)**2*y(3)*y(4) + 75*y(1)**2*y(2)**2*y(4)**2 + 1000*y(1)**2*y(2)*y(3)**3 & + & + 125*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 + 50*y(1)**2*y(2)*y(4)**3 & + & + 1081*y(1)**2*y(3)**4 - 50*y(1)**2*y(3)**3*y(4) - 10*y(1)**2*y(3)**2*y(4)**2 + 45*y(1)**2*y(3) & + & *y(4)**3 + 5*y(1)**2*y(4)**4 + 900*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2)**3*y(3)*y(4) + 90*y(1) & + & *y(2)**3*y(4)**2 + 1800*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) + 315*y(1)*y(2) & + & **2*y(3)*y(4)**2 + 90*y(1)*y(2)**2*y(4)**3 + 4224*y(1)*y(2)*y(3)**4 - 120*y(1)*y(2)*y(3)**3*y(4) & + & + 25*y(1)*y(2)*y(3)**2*y(4)**2 + 165*y(1)*y(2)*y(3)*y(4)**3 + 20*y(1)*y(2)*y(4)**4 + 3324*y(1) & + & *y(3)**5 + 1407*y(1)*y(3)**4*y(4) - 100*y(1)*y(3)**3*y(4)**2 + 70*y(1)*y(3)**2*y(4)**3 + 15*y(1) & + & *y(3)*y(4)**4 + 450*y(2)**4*y(3)**2 + 45*y(2)**4*y(3)*y(4) + 45*y(2)**4*y(4)**2 + 1200*y(2) & + & **3*y(3)**3 + 150*y(2)**3*y(3)**2*y(4) + 210*y(2)**3*y(3)*y(4)**2 + 60*y(2)**3*y(4)**3 & + & + 4224*y(2)**2*y(3)**4 - 120*y(2)**2*y(3)**3*y(4) + 25*y(2)**2*y(3)**2*y(4)**2 + 165*y(2) & + & **2*y(3)*y(4)**3 + 20*y(2)**2*y(4)**4 + 6648*y(2)*y(3)**5 + 2814*y(2)*y(3)**4*y(4) - 200*y(2) & + & *y(3)**3*y(4)**2 + 140*y(2)*y(3)**2*y(4)**3 + 30*y(2)*y(3)*y(4)**4 + 3174*y(3)**6 + 3039*y(3) & + & **5*y(4) + 771*y(3)**4*y(4)**2 + 135*y(3)**3*y(4)**3 + 60*y(3)**2*y(4)**4))/(5*(y(2) + y(3)) & + & **2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 4) = -(4*y(3)**2*(100*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 10*y(1) & - & **2*y(2)*y(4)**2 - 95*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 300*y(1) & - & *y(2)**2*y(3)**2 + 30*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 + 200*y(1) & - & *y(2)*y(3)**3 - 260*y(1)*y(2)*y(3)**2*y(4) + 50*y(1)*y(2)*y(3)*y(4)**2 + 10*y(1) & - & *y(2)*y(4)**3 + 1562*y(1)*y(3)**4 - 190*y(1)*y(3)**3*y(4) + 15*y(1)*y(3)**2*y(4) & - & **2 + 5*y(1)*y(3)*y(4)**3 + 300*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 30*y(2) & - & **3*y(4)**2 + 400*y(2)**2*y(3)**3 - 235*y(2)**2*y(3)**2*y(4) + 85*y(2)**2*y(3) & - & *y(4)**2 + 20*y(2)**2*y(4)**3 + 3224*y(2)*y(3)**4 - 460*y(2)*y(3)**3*y(4) & - & - 35*y(2)*y(3)**2*y(4)**2 + 25*y(2)*y(3)*y(4)**3 + 3124*y(3)**5 + 1467*y(3) & - & **4*y(4) + 110*y(3)**3*y(4)**2 + 105*y(3)**2*y(4)**3))/(5*(y(1) + y(2))*(y(2) & - & + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4)) & - & **2) !& + & 4) = -(4*y(3)**2*(100*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4) & + & **2 - 95*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 300*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2) & + & **2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 + 200*y(1)*y(2)*y(3)**3 - 260*y(1)*y(2)*y(3)**2*y(4) & + & + 50*y(1)*y(2)*y(3)*y(4)**2 + 10*y(1)*y(2)*y(4)**3 + 1562*y(1)*y(3)**4 - 190*y(1)*y(3)**3*y(4) & + & + 15*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4)**3 + 300*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) & + & + 30*y(2)**3*y(4)**2 + 400*y(2)**2*y(3)**3 - 235*y(2)**2*y(3)**2*y(4) + 85*y(2)**2*y(3)*y(4)**2 & + & + 20*y(2)**2*y(4)**3 + 3224*y(2)*y(3)**4 - 460*y(2)*y(3)**3*y(4) - 35*y(2)*y(3)**2*y(4)**2 & + & + 25*y(2)*y(3)*y(4)**3 + 3124*y(3)**5 + 1467*y(3)**4*y(4) + 110*y(3)**3*y(4)**2 + 105*y(3) & + & **2*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 5) = (4*y(3)**2*(50*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 5*y(2)**2*y(4)**2 & - & - 95*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 781*y(3)**4 + 50*y(3)**2*y(4)**2)) & - & /(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 5) = (4*y(3)**2*(50*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 5*y(2)**2*y(4)**2 - 95*y(2)*y(3) & + & **2*y(4) + 5*y(2)*y(3)*y(4)**2 + 781*y(3)**4 + 50*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) & + & + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& y = s_cb(i:i + 3) - s_cb(i - 1:i + 2) beta_coef_${XYZ}$ (i + 1, 1, & - & 0) = (4*y(2)**2*(50*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 5*y(1)**2*y(3)**2 & - & - 95*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 781*y(2)**4 + 50*y(2)**2*y(3)**2)) & - & /(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 0) = (4*y(2)**2*(50*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 5*y(1)**2*y(3)**2 - 95*y(1)*y(2) & + & **2*y(3) + 5*y(1)*y(2)*y(3)**2 + 781*y(2)**4 + 50*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) & + & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 1) = -(4*y(2)**2*(105*y(1)**3*y(2)**2 + 25*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2) & - & *y(4) + 20*y(1)**3*y(3)**2 + 10*y(1)**3*y(3)*y(4) + 110*y(1)**2*y(2)**3 - 35*y(1) & - & **2*y(2)**2*y(3) + 15*y(1)**2*y(2)**2*y(4) + 85*y(1)**2*y(2)*y(3)**2 + 50*y(1) & - & **2*y(2)*y(3)*y(4) + 5*y(1)**2*y(2)*y(4)**2 + 30*y(1)**2*y(3)**3 + 30*y(1) & - & **2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 + 1467*y(1)*y(2)**4 - 460*y(1)*y(2) & - & **3*y(3) - 190*y(1)*y(2)**3*y(4) - 235*y(1)*y(2)**2*y(3)**2 - 260*y(1)*y(2) & - & **2*y(3)*y(4) - 95*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2) & - & *y(3)**2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 3124*y(2)**5 + 3224*y(2)**4*y(3) & - & + 1562*y(2)**4*y(4) + 400*y(2)**3*y(3)**2 + 200*y(2)**3*y(3)*y(4) + 300*y(2) & - & **2*y(3)**3 + 300*y(2)**2*y(3)**2*y(4) + 100*y(2)**2*y(3)*y(4)**2))/(5*(y(2) & - & + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & 1) = -(4*y(2)**2*(105*y(1)**3*y(2)**2 + 25*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1) & + & **3*y(3)**2 + 10*y(1)**3*y(3)*y(4) + 110*y(1)**2*y(2)**3 - 35*y(1)**2*y(2)**2*y(3) + 15*y(1) & + & **2*y(2)**2*y(4) + 85*y(1)**2*y(2)*y(3)**2 + 50*y(1)**2*y(2)*y(3)*y(4) + 5*y(1)**2*y(2)*y(4)**2 & + & + 30*y(1)**2*y(3)**3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 + 1467*y(1)*y(2)**4 & + & - 460*y(1)*y(2)**3*y(3) - 190*y(1)*y(2)**3*y(4) - 235*y(1)*y(2)**2*y(3)**2 - 260*y(1)*y(2) & + & **2*y(3)*y(4) - 95*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2)*y(3)**2*y(4) & + & + 10*y(1)*y(2)*y(3)*y(4)**2 + 3124*y(2)**5 + 3224*y(2)**4*y(3) + 1562*y(2)**4*y(4) + 400*y(2) & + & **3*y(3)**2 + 200*y(2)**3*y(3)*y(4) + 300*y(2)**2*y(3)**3 + 300*y(2)**2*y(3)**2*y(4) + 100*y(2) & + & **2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4)) & + & **2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 2) = -(4*y(2)**2*(100*y(1)*y(2)**3 - 190*y(2)**2*y(3)**2 + 10*y(1)*y(3)**3 & - & + 5*y(2)*y(3)**3 - 95*y(2)**3*y(3) - 1562*y(2)**4 + 15*y(1)*y(2)*y(3)**2 & - & + 205*y(1)*y(2)**2*y(3) + 100*y(1)*y(2)**2*y(4) + 10*y(1)*y(3)**2*y(4) + 5*y(2) & - & *y(3)**2*y(4) - 95*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2)) & - & *(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & 2) = -(4*y(2)**2*(100*y(1)*y(2)**3 - 190*y(2)**2*y(3)**2 + 10*y(1)*y(3)**3 + 5*y(2)*y(3)**3 & + & - 95*y(2)**3*y(3) - 1562*y(2)**4 + 15*y(1)*y(2)*y(3)**2 + 205*y(1)*y(2)**2*y(3) + 100*y(1)*y(2) & + & **2*y(4) + 10*y(1)*y(3)**2*y(4) + 5*y(2)*y(3)**2*y(4) - 95*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3) & + & *y(4)))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) & + & + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 3) = (4*y(2)**2*(60*y(1)**4*y(2)**2 + 30*y(1)**4*y(2)*y(3) + 15*y(1)**4*y(2)*y(4) & - & + 20*y(1)**4*y(3)**2 + 20*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 135*y(1) & - & **3*y(2)**3 + 140*y(1)**3*y(2)**2*y(3) + 70*y(1)**3*y(2)**2*y(4) + 165*y(1) & - & **3*y(2)*y(3)**2 + 165*y(1)**3*y(2)*y(3)*y(4) + 45*y(1)**3*y(2)*y(4)**2 + 60*y(1) & - & **3*y(3)**3 + 90*y(1)**3*y(3)**2*y(4) + 50*y(1)**3*y(3)*y(4)**2 + 10*y(1)**3*y(4) & - & **3 + 771*y(1)**2*y(2)**4 - 200*y(1)**2*y(2)**3*y(3) - 100*y(1)**2*y(2)**3*y(4) & - & + 25*y(1)**2*y(2)**2*y(3)**2 + 25*y(1)**2*y(2)**2*y(3)*y(4) - 10*y(1)**2*y(2) & - & **2*y(4)**2 + 210*y(1)**2*y(2)*y(3)**3 + 315*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1) & - & **2*y(2)*y(3)*y(4)**2 + 35*y(1)**2*y(2)*y(4)**3 + 45*y(1)**2*y(3)**4 + 90*y(1) & - & **2*y(3)**3*y(4) + 75*y(1)**2*y(3)**2*y(4)**2 + 30*y(1)**2*y(3)*y(4)**3 + 5*y(1) & - & **2*y(4)**4 + 3039*y(1)*y(2)**5 + 2814*y(1)*y(2)**4*y(3) + 1407*y(1)*y(2)**4*y(4) & - & - 120*y(1)*y(2)**3*y(3)**2 - 120*y(1)*y(2)**3*y(3)*y(4) - 50*y(1)*y(2)**3*y(4) & - & **2 + 150*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) + 125*y(1)*y(2) & - & **2*y(3)*y(4)**2 + 25*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2) & - & *y(3)**3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1) & - & *y(2)*y(4)**4 + 3174*y(2)**6 + 6648*y(2)**5*y(3) + 3324*y(2)**5*y(4) + 4224*y(2) & - & **4*y(3)**2 + 4224*y(2)**4*y(3)*y(4) + 1081*y(2)**4*y(4)**2 + 1200*y(2)**3*y(3) & - & **3 + 1800*y(2)**3*y(3)**2*y(4) + 1000*y(2)**3*y(3)*y(4)**2 + 200*y(2)**3*y(4) & - & **3 + 450*y(2)**2*y(3)**4 + 900*y(2)**2*y(3)**3*y(4) + 750*y(2)**2*y(3)**2*y(4) & - & **2 + 300*y(2)**2*y(3)*y(4)**3 + 50*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) & - & + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 3) = (4*y(2)**2*(60*y(1)**4*y(2)**2 + 30*y(1)**4*y(2)*y(3) + 15*y(1)**4*y(2)*y(4) + 20*y(1) & + & **4*y(3)**2 + 20*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 135*y(1)**3*y(2)**3 + 140*y(1)**3*y(2) & + & **2*y(3) + 70*y(1)**3*y(2)**2*y(4) + 165*y(1)**3*y(2)*y(3)**2 + 165*y(1)**3*y(2)*y(3)*y(4) & + & + 45*y(1)**3*y(2)*y(4)**2 + 60*y(1)**3*y(3)**3 + 90*y(1)**3*y(3)**2*y(4) + 50*y(1)**3*y(3)*y(4) & + & **2 + 10*y(1)**3*y(4)**3 + 771*y(1)**2*y(2)**4 - 200*y(1)**2*y(2)**3*y(3) - 100*y(1)**2*y(2) & + & **3*y(4) + 25*y(1)**2*y(2)**2*y(3)**2 + 25*y(1)**2*y(2)**2*y(3)*y(4) - 10*y(1)**2*y(2)**2*y(4) & + & **2 + 210*y(1)**2*y(2)*y(3)**3 + 315*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 & + & + 35*y(1)**2*y(2)*y(4)**3 + 45*y(1)**2*y(3)**4 + 90*y(1)**2*y(3)**3*y(4) + 75*y(1)**2*y(3) & + & **2*y(4)**2 + 30*y(1)**2*y(3)*y(4)**3 + 5*y(1)**2*y(4)**4 + 3039*y(1)*y(2)**5 + 2814*y(1)*y(2) & + & **4*y(3) + 1407*y(1)*y(2)**4*y(4) - 120*y(1)*y(2)**3*y(3)**2 - 120*y(1)*y(2)**3*y(3)*y(4) & + & - 50*y(1)*y(2)**3*y(4)**2 + 150*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) + 125*y(1) & + & *y(2)**2*y(3)*y(4)**2 + 25*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2)*y(3) & + & **3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1)*y(2)*y(4)**4 & + & + 3174*y(2)**6 + 6648*y(2)**5*y(3) + 3324*y(2)**5*y(4) + 4224*y(2)**4*y(3)**2 + 4224*y(2) & + & **4*y(3)*y(4) + 1081*y(2)**4*y(4)**2 + 1200*y(2)**3*y(3)**3 + 1800*y(2)**3*y(3)**2*y(4) & + & + 1000*y(2)**3*y(3)*y(4)**2 + 200*y(2)**3*y(4)**3 + 450*y(2)**2*y(3)**4 + 900*y(2)**2*y(3) & + & **3*y(4) + 750*y(2)**2*y(3)**2*y(4)**2 + 300*y(2)**2*y(3)*y(4)**3 + 50*y(2)**2*y(4)**4)) & + & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4)) & + & **2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 4) = (4*y(2)**2*(105*y(1)**2*y(2)**3 + 220*y(1)**2*y(2)**2*y(3) + 110*y(1) & - & **2*y(2)**2*y(4) + 35*y(1)**2*y(2)*y(3)**2 + 35*y(1)**2*y(2)*y(3)*y(4) + 5*y(1) & - & **2*y(2)*y(4)**2 + 20*y(1)**2*y(3)**3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3) & - & *y(4)**2 - 1452*y(1)*y(2)**4 + 250*y(1)*y(2)**3*y(3) + 125*y(1)*y(2)**3*y(4) & - & + 100*y(1)*y(2)**2*y(3)**2 + 100*y(1)*y(2)**2*y(3)*y(4) + 20*y(1)*y(2)**2*y(4) & - & **2 + 90*y(1)*y(2)*y(3)**3 + 135*y(1)*y(2)*y(3)**2*y(4) + 55*y(1)*y(2)*y(3)*y(4) & - & **2 + 5*y(1)*y(2)*y(4)**3 + 30*y(1)*y(3)**4 + 60*y(1)*y(3)**3*y(4) + 40*y(1)*y(3) & - & **2*y(4)**2 + 10*y(1)*y(3)*y(4)**3 - 3219*y(2)**5 - 3694*y(2)**4*y(3) - 1847*y(2) & - & **4*y(4) - 1040*y(2)**3*y(3)**2 - 1040*y(2)**3*y(3)*y(4) - 285*y(2)**3*y(4)**2 & - & - 550*y(2)**2*y(3)**3 - 825*y(2)**2*y(3)**2*y(4) - 465*y(2)**2*y(3)*y(4)**2 & - & - 95*y(2)**2*y(4)**3 + 15*y(2)*y(3)**4 + 30*y(2)*y(3)**3*y(4) + 20*y(2)*y(3) & - & **2*y(4)**2 + 5*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) & - & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & 4) = (4*y(2)**2*(105*y(1)**2*y(2)**3 + 220*y(1)**2*y(2)**2*y(3) + 110*y(1)**2*y(2)**2*y(4) & + & + 35*y(1)**2*y(2)*y(3)**2 + 35*y(1)**2*y(2)*y(3)*y(4) + 5*y(1)**2*y(2)*y(4)**2 + 20*y(1)**2*y(3) & + & **3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 - 1452*y(1)*y(2)**4 + 250*y(1)*y(2) & + & **3*y(3) + 125*y(1)*y(2)**3*y(4) + 100*y(1)*y(2)**2*y(3)**2 + 100*y(1)*y(2)**2*y(3)*y(4) & + & + 20*y(1)*y(2)**2*y(4)**2 + 90*y(1)*y(2)*y(3)**3 + 135*y(1)*y(2)*y(3)**2*y(4) + 55*y(1)*y(2) & + & *y(3)*y(4)**2 + 5*y(1)*y(2)*y(4)**3 + 30*y(1)*y(3)**4 + 60*y(1)*y(3)**3*y(4) + 40*y(1)*y(3) & + & **2*y(4)**2 + 10*y(1)*y(3)*y(4)**3 - 3219*y(2)**5 - 3694*y(2)**4*y(3) - 1847*y(2)**4*y(4) & + & - 1040*y(2)**3*y(3)**2 - 1040*y(2)**3*y(3)*y(4) - 285*y(2)**3*y(4)**2 - 550*y(2)**2*y(3)**3 & + & - 825*y(2)**2*y(3)**2*y(4) - 465*y(2)**2*y(3)*y(4)**2 - 95*y(2)**2*y(4)**3 + 15*y(2)*y(3)**4 & + & + 30*y(2)*y(3)**3*y(4) + 20*y(2)*y(3)**2*y(4)**2 + 5*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) & + & + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 5) = (4*y(2)**2*(831*y(2)**4 + 200*y(2)**3*y(3) + 100*y(2)**3*y(4) + 205*y(2) & - & **2*y(3)**2 + 205*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 & - & + 15*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) & - & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & 5) = (4*y(2)**2*(831*y(2)**4 + 200*y(2)**3*y(3) + 100*y(2)**3*y(4) + 205*y(2)**2*y(3)**2 & + & + 205*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 + 15*y(2)*y(3)**2*y(4) + 5*y(2) & + & *y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) & + & + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& y = s_cb(i + 1:i + 4) - s_cb(i:i + 3) beta_coef_${XYZ}$ (i + 1, 0, & - & 0) = (4*y(1)**2*(831*y(1)**4 + 200*y(1)**3*y(2) + 100*y(1)**3*y(3) + 205*y(1) & - & **2*y(2)**2 + 205*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 & - & + 15*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 5*y(2)**4 + 10*y(2)**3*y(3) & - & + 5*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & 0) = (4*y(1)**2*(831*y(1)**4 + 200*y(1)**3*y(2) + 100*y(1)**3*y(3) + 205*y(1)**2*y(2)**2 & + & + 205*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 + 15*y(1)*y(2)**2*y(3) + 5*y(1) & + & *y(2)*y(3)**2 + 5*y(2)**4 + 10*y(2)**3*y(3) + 5*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) & + & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 1) = -(4*y(1)**2*(1662*y(1)**5 + 3824*y(1)**4*y(2) + 3624*y(1)**4*y(3) & - & + 1762*y(1)**4*y(4) + 1515*y(1)**3*y(2)**2 + 2115*y(1)**3*y(2)*y(3) + 805*y(1) & - & **3*y(2)*y(4) + 700*y(1)**3*y(3)**2 + 500*y(1)**3*y(3)*y(4) + 100*y(1)**3*y(4) & - & **2 + 1060*y(1)**2*y(2)**3 + 2205*y(1)**2*y(2)**2*y(3) + 835*y(1)**2*y(2)**2*y(4) & - & + 1445*y(1)**2*y(2)*y(3)**2 + 1030*y(1)**2*y(2)*y(3)*y(4) + 205*y(1)**2*y(2)*y(4) & - & **2 + 300*y(1)**2*y(3)**3 + 300*y(1)**2*y(3)**2*y(4) + 100*y(1)**2*y(3)*y(4)**2 & - & + 75*y(1)*y(2)**4 + 180*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) + 135*y(1)*y(2) & - & **2*y(3)**2 + 90*y(1)*y(2)**2*y(3)*y(4) + 15*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2) & - & *y(3)**3 + 30*y(1)*y(2)*y(3)**2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 30*y(2)**5 & - & + 90*y(2)**4*y(3) + 30*y(2)**4*y(4) + 90*y(2)**3*y(3)**2 + 60*y(2)**3*y(3)*y(4) & - & + 10*y(2)**3*y(4)**2 + 30*y(2)**2*y(3)**3 + 30*y(2)**2*y(3)**2*y(4) + 10*y(2) & - & **2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & - & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 1) = -(4*y(1)**2*(1662*y(1)**5 + 3824*y(1)**4*y(2) + 3624*y(1)**4*y(3) + 1762*y(1)**4*y(4) & + & + 1515*y(1)**3*y(2)**2 + 2115*y(1)**3*y(2)*y(3) + 805*y(1)**3*y(2)*y(4) + 700*y(1)**3*y(3)**2 & + & + 500*y(1)**3*y(3)*y(4) + 100*y(1)**3*y(4)**2 + 1060*y(1)**2*y(2)**3 + 2205*y(1)**2*y(2)**2*y(3) & + & + 835*y(1)**2*y(2)**2*y(4) + 1445*y(1)**2*y(2)*y(3)**2 + 1030*y(1)**2*y(2)*y(3)*y(4) + 205*y(1) & + & **2*y(2)*y(4)**2 + 300*y(1)**2*y(3)**3 + 300*y(1)**2*y(3)**2*y(4) + 100*y(1)**2*y(3)*y(4)**2 & + & + 75*y(1)*y(2)**4 + 180*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) + 135*y(1)*y(2)**2*y(3)**2 & + & + 90*y(1)*y(2)**2*y(3)*y(4) + 15*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2)*y(3) & + & **2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 30*y(2)**5 + 90*y(2)**4*y(3) + 30*y(2)**4*y(4) + 90*y(2) & + & **3*y(3)**2 + 60*y(2)**3*y(3)*y(4) + 10*y(2)**3*y(4)**2 + 30*y(2)**2*y(3)**3 + 30*y(2)**2*y(3) & + & **2*y(4) + 10*y(2)**2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & + & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 2) = (4*y(1)**2*(1767*y(1)**4 + 725*y(1)**3*y(2) + 415*y(1)**3*y(3) + 105*y(4) & - & *y(1)**3 + 665*y(1)**2*y(2)**2 + 775*y(1)**2*y(2)*y(3) + 220*y(4)*y(1)**2*y(2) & - & + 215*y(1)**2*y(3)**2 + 110*y(4)*y(1)**2*y(3) + 75*y(1)*y(2)**3 + 130*y(1)*y(2) & - & **2*y(3) + 35*y(4)*y(1)*y(2)**2 + 60*y(1)*y(2)*y(3)**2 + 35*y(4)*y(1)*y(2)*y(3) & - & + 5*y(1)*y(3)**3 + 5*y(4)*y(1)*y(3)**2 + 30*y(2)**4 + 70*y(2)**3*y(3) + 20*y(4) & - & *y(2)**3 + 50*y(2)**2*y(3)**2 + 30*y(4)*y(2)**2*y(3) + 10*y(2)*y(3)**3 + 10*y(4) & - & *y(2)*y(3)**2))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & 2) = (4*y(1)**2*(1767*y(1)**4 + 725*y(1)**3*y(2) + 415*y(1)**3*y(3) + 105*y(4)*y(1)**3 & + & + 665*y(1)**2*y(2)**2 + 775*y(1)**2*y(2)*y(3) + 220*y(4)*y(1)**2*y(2) + 215*y(1)**2*y(3)**2 & + & + 110*y(4)*y(1)**2*y(3) + 75*y(1)*y(2)**3 + 130*y(1)*y(2)**2*y(3) + 35*y(4)*y(1)*y(2)**2 & + & + 60*y(1)*y(2)*y(3)**2 + 35*y(4)*y(1)*y(2)*y(3) + 5*y(1)*y(3)**3 + 5*y(4)*y(1)*y(3)**2 + 30*y(2) & + & **4 + 70*y(2)**3*y(3) + 20*y(4)*y(2)**3 + 50*y(2)**2*y(3)**2 + 30*y(4)*y(2)**2*y(3) + 10*y(2) & + & *y(3)**3 + 10*y(4)*y(2)*y(3)**2))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 3) = (4*y(1)**2*(831*y(1)**6 + 3624*y(1)**5*y(2) + 3524*y(1)**5*y(3) + 1762*y(1) & - & **5*y(4) + 4884*y(1)**4*y(2)**2 + 9058*y(1)**4*y(2)*y(3) + 4529*y(1)**4*y(2)*y(4) & - & + 4224*y(1)**4*y(3)**2 + 4224*y(1)**4*y(3)*y(4) + 1081*y(1)**4*y(4)**2 & - & + 2565*y(1)**3*y(2)**3 + 6120*y(1)**3*y(2)**2*y(3) + 3060*y(1)**3*y(2)**2*y(4) & - & + 4755*y(1)**3*y(2)*y(3)**2 + 4755*y(1)**3*y(2)*y(3)*y(4) + 1315*y(1)**3*y(2) & - & *y(4)**2 + 1200*y(1)**3*y(3)**3 + 1800*y(1)**3*y(3)**2*y(4) + 1000*y(1)**3*y(3) & - & *y(4)**2 + 200*y(1)**3*y(4)**3 + 1395*y(1)**2*y(2)**4 + 4380*y(1)**2*y(2)**3*y(3) & - & + 2190*y(1)**2*y(2)**3*y(4) + 5025*y(1)**2*y(2)**2*y(3)**2 + 5025*y(1)**2*y(2) & - & **2*y(3)*y(4) + 1390*y(1)**2*y(2)**2*y(4)**2 + 2490*y(1)**2*y(2)*y(3)**3 & - & + 3735*y(1)**2*y(2)*y(3)**2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 415*y(1) & - & **2*y(2)*y(4)**3 + 450*y(1)**2*y(3)**4 + 900*y(1)**2*y(3)**3*y(4) + 750*y(1) & - & **2*y(3)**2*y(4)**2 + 300*y(1)**2*y(3)*y(4)**3 + 50*y(1)**2*y(4)**4 + 135*y(1) & - & *y(2)**5 + 450*y(1)*y(2)**4*y(3) + 225*y(1)*y(2)**4*y(4) + 540*y(1)*y(2)**3*y(3) & - & **2 + 540*y(1)*y(2)**3*y(3)*y(4) + 150*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2) & - & **2*y(3)**3 + 405*y(1)*y(2)**2*y(3)**2*y(4) + 225*y(1)*y(2)**2*y(3)*y(4)**2 & - & + 45*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2)*y(3)**3*y(4) & - & + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1)*y(2)*y(4)**4 & - & + 45*y(2)**6 + 180*y(2)**5*y(3) + 90*y(2)**5*y(4) + 270*y(2)**4*y(3)**2 & - & + 270*y(2)**4*y(3)*y(4) + 75*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2) & - & **3*y(3)**2*y(4) + 150*y(2)**3*y(3)*y(4)**2 + 30*y(2)**3*y(4)**3 + 45*y(2) & - & **2*y(3)**4 + 90*y(2)**2*y(3)**3*y(4) + 75*y(2)**2*y(3)**2*y(4)**2 + 30*y(2) & - & **2*y(3)*y(4)**3 + 5*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3)) & - & **2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 3) = (4*y(1)**2*(831*y(1)**6 + 3624*y(1)**5*y(2) + 3524*y(1)**5*y(3) + 1762*y(1)**5*y(4) & + & + 4884*y(1)**4*y(2)**2 + 9058*y(1)**4*y(2)*y(3) + 4529*y(1)**4*y(2)*y(4) + 4224*y(1)**4*y(3)**2 & + & + 4224*y(1)**4*y(3)*y(4) + 1081*y(1)**4*y(4)**2 + 2565*y(1)**3*y(2)**3 + 6120*y(1)**3*y(2) & + & **2*y(3) + 3060*y(1)**3*y(2)**2*y(4) + 4755*y(1)**3*y(2)*y(3)**2 + 4755*y(1)**3*y(2)*y(3)*y(4) & + & + 1315*y(1)**3*y(2)*y(4)**2 + 1200*y(1)**3*y(3)**3 + 1800*y(1)**3*y(3)**2*y(4) + 1000*y(1) & + & **3*y(3)*y(4)**2 + 200*y(1)**3*y(4)**3 + 1395*y(1)**2*y(2)**4 + 4380*y(1)**2*y(2)**3*y(3) & + & + 2190*y(1)**2*y(2)**3*y(4) + 5025*y(1)**2*y(2)**2*y(3)**2 + 5025*y(1)**2*y(2)**2*y(3)*y(4) & + & + 1390*y(1)**2*y(2)**2*y(4)**2 + 2490*y(1)**2*y(2)*y(3)**3 + 3735*y(1)**2*y(2)*y(3)**2*y(4) & + & + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 415*y(1)**2*y(2)*y(4)**3 + 450*y(1)**2*y(3)**4 + 900*y(1) & + & **2*y(3)**3*y(4) + 750*y(1)**2*y(3)**2*y(4)**2 + 300*y(1)**2*y(3)*y(4)**3 + 50*y(1)**2*y(4)**4 & + & + 135*y(1)*y(2)**5 + 450*y(1)*y(2)**4*y(3) + 225*y(1)*y(2)**4*y(4) + 540*y(1)*y(2)**3*y(3)**2 & + & + 540*y(1)*y(2)**3*y(3)*y(4) + 150*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1) & + & *y(2)**2*y(3)**2*y(4) + 225*y(1)*y(2)**2*y(3)*y(4)**2 + 45*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2) & + & *y(3)**4 + 90*y(1)*y(2)*y(3)**3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 & + & + 5*y(1)*y(2)*y(4)**4 + 45*y(2)**6 + 180*y(2)**5*y(3) + 90*y(2)**5*y(4) + 270*y(2)**4*y(3)**2 & + & + 270*y(2)**4*y(3)*y(4) + 75*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3)**2*y(4) & + & + 150*y(2)**3*y(3)*y(4)**2 + 30*y(2)**3*y(4)**3 + 45*y(2)**2*y(3)**4 + 90*y(2)**2*y(3)**3*y(4) & + & + 75*y(2)**2*y(3)**2*y(4)**2 + 30*y(2)**2*y(3)*y(4)**3 + 5*y(2)**2*y(4)**4))/(5*(y(2) + y(3)) & + & **2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 4) = -(4*y(1)**2*(1767*y(1)**5 + 4464*y(1)**4*y(2) + 4154*y(1)**4*y(3) & - & + 2077*y(1)**4*y(4) + 2655*y(1)**3*y(2)**2 + 4010*y(1)**3*y(2)*y(3) + 2005*y(1) & - & **3*y(2)*y(4) + 1460*y(1)**3*y(3)**2 + 1460*y(1)**3*y(3)*y(4) + 415*y(1)**3*y(4) & - & **2 + 1800*y(1)**2*y(2)**3 + 4000*y(1)**2*y(2)**2*y(3) + 2000*y(1)**2*y(2) & - & **2*y(4) + 2850*y(1)**2*y(2)*y(3)**2 + 2850*y(1)**2*y(2)*y(3)*y(4) + 790*y(1) & - & **2*y(2)*y(4)**2 + 650*y(1)**2*y(3)**3 + 975*y(1)**2*y(3)**2*y(4) + 535*y(1) & - & **2*y(3)*y(4)**2 + 105*y(1)**2*y(4)**3 + 270*y(1)*y(2)**4 + 720*y(1)*y(2)**3*y(3) & - & + 360*y(1)*y(2)**3*y(4) + 645*y(1)*y(2)**2*y(3)**2 + 645*y(1)*y(2)**2*y(3)*y(4) & - & + 165*y(1)*y(2)**2*y(4)**2 + 210*y(1)*y(2)*y(3)**3 + 315*y(1)*y(2)*y(3)**2*y(4) & - & + 155*y(1)*y(2)*y(3)*y(4)**2 + 25*y(1)*y(2)*y(4)**3 + 15*y(1)*y(3)**4 + 30*y(1) & - & *y(3)**3*y(4) + 20*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4)**3 + 90*y(2)**5 & - & + 300*y(2)**4*y(3) + 150*y(2)**4*y(4) + 360*y(2)**3*y(3)**2 + 360*y(2)**3*y(3) & - & *y(4) + 90*y(2)**3*y(4)**2 + 180*y(2)**2*y(3)**3 + 270*y(2)**2*y(3)**2*y(4) & - & + 130*y(2)**2*y(3)*y(4)**2 + 20*y(2)**2*y(4)**3 + 30*y(2)*y(3)**4 + 60*y(2)*y(3) & - & **3*y(4) + 40*y(2)*y(3)**2*y(4)**2 + 10*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2)) & - & *(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & 4) = -(4*y(1)**2*(1767*y(1)**5 + 4464*y(1)**4*y(2) + 4154*y(1)**4*y(3) + 2077*y(1)**4*y(4) & + & + 2655*y(1)**3*y(2)**2 + 4010*y(1)**3*y(2)*y(3) + 2005*y(1)**3*y(2)*y(4) + 1460*y(1)**3*y(3)**2 & + & + 1460*y(1)**3*y(3)*y(4) + 415*y(1)**3*y(4)**2 + 1800*y(1)**2*y(2)**3 + 4000*y(1)**2*y(2) & + & **2*y(3) + 2000*y(1)**2*y(2)**2*y(4) + 2850*y(1)**2*y(2)*y(3)**2 + 2850*y(1)**2*y(2)*y(3)*y(4) & + & + 790*y(1)**2*y(2)*y(4)**2 + 650*y(1)**2*y(3)**3 + 975*y(1)**2*y(3)**2*y(4) + 535*y(1)**2*y(3) & + & *y(4)**2 + 105*y(1)**2*y(4)**3 + 270*y(1)*y(2)**4 + 720*y(1)*y(2)**3*y(3) + 360*y(1)*y(2) & + & **3*y(4) + 645*y(1)*y(2)**2*y(3)**2 + 645*y(1)*y(2)**2*y(3)*y(4) + 165*y(1)*y(2)**2*y(4)**2 & + & + 210*y(1)*y(2)*y(3)**3 + 315*y(1)*y(2)*y(3)**2*y(4) + 155*y(1)*y(2)*y(3)*y(4)**2 + 25*y(1)*y(2) & + & *y(4)**3 + 15*y(1)*y(3)**4 + 30*y(1)*y(3)**3*y(4) + 20*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4) & + & **3 + 90*y(2)**5 + 300*y(2)**4*y(3) + 150*y(2)**4*y(4) + 360*y(2)**3*y(3)**2 + 360*y(2)**3*y(3) & + & *y(4) + 90*y(2)**3*y(4)**2 + 180*y(2)**2*y(3)**3 + 270*y(2)**2*y(3)**2*y(4) + 130*y(2)**2*y(3) & + & *y(4)**2 + 20*y(2)**2*y(4)**3 + 30*y(2)*y(3)**4 + 60*y(2)*y(3)**3*y(4) + 40*y(2)*y(3)**2*y(4) & + & **2 + 10*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 5) = (4*y(1)**2*(996*y(1)**4 + 675*y(1)**3*y(2) + 450*y(1)**3*y(3) + 225*y(1) & - & **3*y(4) + 600*y(1)**2*y(2)**2 + 800*y(1)**2*y(2)*y(3) + 400*y(1)**2*y(2)*y(4) & - & + 260*y(1)**2*y(3)**2 + 260*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 135*y(1) & - & *y(2)**3 + 270*y(1)*y(2)**2*y(3) + 135*y(1)*y(2)**2*y(4) + 165*y(1)*y(2)*y(3)**2 & - & + 165*y(1)*y(2)*y(3)*y(4) + 30*y(1)*y(2)*y(4)**2 + 30*y(1)*y(3)**3 + 45*y(1)*y(3) & - & **2*y(4) + 15*y(1)*y(3)*y(4)**2 + 45*y(2)**4 + 120*y(2)**3*y(3) + 60*y(2)**3*y(4) & - & + 110*y(2)**2*y(3)**2 + 110*y(2)**2*y(3)*y(4) + 20*y(2)**2*y(4)**2 + 40*y(2)*y(3) & - & **3 + 60*y(2)*y(3)**2*y(4) + 20*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) & - & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & 5) = (4*y(1)**2*(996*y(1)**4 + 675*y(1)**3*y(2) + 450*y(1)**3*y(3) + 225*y(1)**3*y(4) + 600*y(1) & + & **2*y(2)**2 + 800*y(1)**2*y(2)*y(3) + 400*y(1)**2*y(2)*y(4) + 260*y(1)**2*y(3)**2 + 260*y(1) & + & **2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 135*y(1)*y(2)**3 + 270*y(1)*y(2)**2*y(3) + 135*y(1)*y(2) & + & **2*y(4) + 165*y(1)*y(2)*y(3)**2 + 165*y(1)*y(2)*y(3)*y(4) + 30*y(1)*y(2)*y(4)**2 + 30*y(1)*y(3) & + & **3 + 45*y(1)*y(3)**2*y(4) + 15*y(1)*y(3)*y(4)**2 + 45*y(2)**4 + 120*y(2)**3*y(3) + 60*y(2) & + & **3*y(4) + 110*y(2)**2*y(3)**2 + 110*y(2)**2*y(3)*y(4) + 20*y(2)**2*y(4)**2 + 40*y(2)*y(3)**3 & + & + 60*y(2)*y(3)**2*y(4) + 20*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) + 5*y(3)**2*y(4)**2) & + & )/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& end do else ! TENO (only supports uniform grid) ! (Fu, et al., 2016) Table 2 (for right flux) @@ -860,15 +801,16 @@ contains nullify (s_cb) end subroutine s_compute_weno_coefficients + !> @brief Performs WENO reconstruction of left and right cell-boundary values from cell-averaged variables. subroutine s_weno(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, weno_dir, is1_weno_d, & - & is2_weno_d, is3_weno_d) + & is2_weno_d, is3_weno_d) type(scalar_field), dimension(1:), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & - & vL_rs_vf_z + & vL_rs_vf_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_rs_vf_x, vR_rs_vf_y, & - & vR_rs_vf_z + & vR_rs_vf_z integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is1_weno_d, is2_weno_d, is3_weno_d @@ -968,23 +910,23 @@ contains if (wenojs) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then ! Borges, et al. (2008) tau = abs(beta(1) - beta(0)) alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + tau/beta(0:weno_num_stencils)) + & j)*(1._wp + tau/beta(0:weno_num_stencils)) end if omega = alpha/sum(alpha) @@ -998,20 +940,20 @@ contains if (wenojs) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + tau/beta(0:weno_num_stencils)) + & j)*(1._wp + tau/beta(0:weno_num_stencils)) end if omega = alpha/sum(alpha) @@ -1048,32 +990,32 @@ contains dvd(-2) = v_rs_ws_${XYZ}$ (j - 1, k, l, i) - v_rs_ws_${XYZ}$ (j - 2, k, l, i) poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 0, & - & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(0) + & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(0) poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 1, & - & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(-1) + & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(-1) poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 2, & - & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-2) + & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-2) beta(0) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & - & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 2)*dvd(0)*dvd(0) + weno_eps + & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 2)*dvd(0)*dvd(0) + weno_eps beta(1) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & - & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 2)*dvd(-1)*dvd(-1) + weno_eps + & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 2)*dvd(-1)*dvd(-1) + weno_eps beta(2) = beta_coef_${XYZ}$ (j, 2, 0)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & - & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 2)*dvd(-2)*dvd(-2) + weno_eps + & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 2)*dvd(-2)*dvd(-2) + weno_eps if (wenojs) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then ! Borges, et al. (2008) @@ -1081,8 +1023,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbL_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))) & - & ! Equation 28 (note: weno_eps was already added to beta) + & j)*(1._wp + (tau/beta(q))) & + & ! Equation 28 (note: weno_eps was already added to beta) end do else if (teno) then ! Fu, et al. (2016) @@ -1092,7 +1034,7 @@ contains do q = 0, weno_num_stencils alpha(q) = 1._wp + tau/beta(q) ! Equation 22 (reuse alpha as gamma; pick C=1 & q=6) alpha(q) = (alpha(q)**3._wp) & - & **2._wp ! Equation 22 cont. (some CPU compilers cannot optimize x**6.0) + & **2._wp ! Equation 22 cont. (some CPU compilers cannot optimize x**6.0) end do omega = alpha/sum(alpha) ! Equation 25 (reuse omega as xi) @@ -1114,25 +1056,25 @@ contains ! reconstruct from right side poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 0, & - & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(0) + & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(0) poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 1, & - & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(-1) + & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(-1) poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 2, & - & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-2) + & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-2) if (wenojs) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils @@ -1188,17 +1130,17 @@ contains dvd(-3) = v_rs_ws_${XYZ}$ (j - 2, k, l, i) - v_rs_ws_${XYZ}$ (j - 3, k, l, i) poly(3) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 0, & - & 0)*dvd(2) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, & - & 0, 2)*dvd(0) + & 0)*dvd(2) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, & + & 0, 2)*dvd(0) poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 1, & - & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, & - & 1, 2)*dvd(-1) + & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, & + & 1, 2)*dvd(-1) poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 2, & - & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 2, & - & 1)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 2, 2)*dvd(-2) + & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, & + & 2, 2)*dvd(-2) poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 3, & - & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 3, & - & 1)*dvd(-2) + poly_coef_cbL_${XYZ}$ (j, 3, 2)*dvd(-3) + & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 3, & + & 1)*dvd(-2) + poly_coef_cbL_${XYZ}$ (j, 3, 2)*dvd(-3) else #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 ! (Fu, et al., 2016) Table 1 @@ -1217,42 +1159,42 @@ contains if (.not. teno) then beta(3) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(2)*dvd(2) + beta_coef_${XYZ}$ (j, 0, & - & 1)*dvd(2)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & - & 2)*dvd(2)*dvd(0) + beta_coef_${XYZ}$ (j, 0, & - & 3)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & - & 4)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 5)*dvd(0)*dvd(0) + weno_eps + & 1)*dvd(2)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & + & 2)*dvd(2)*dvd(0) + beta_coef_${XYZ}$ (j, 0, & + & 3)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & + & 4)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 5)*dvd(0)*dvd(0) + weno_eps beta(2) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 1, & - & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & - & 2)*dvd(1)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, & - & 3)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & - & 4)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 5)*dvd(-1)*dvd(-1) + weno_eps + & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & + & 2)*dvd(1)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, & + & 3)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & + & 4)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 5)*dvd(-1)*dvd(-1) + weno_eps beta(1) = beta_coef_${XYZ}$ (j, 2, 0)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 2, & - & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & - & 2)*dvd(0)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, & - & 3)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & - & 4)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 5)*dvd(-2)*dvd(-2) + weno_eps + & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & + & 2)*dvd(0)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, & + & 3)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & + & 4)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 5)*dvd(-2)*dvd(-2) + weno_eps beta(0) = beta_coef_${XYZ}$ (j, 3, 0)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 3, & - & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & - & 2)*dvd(-1)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, & - & 3)*dvd(-2)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & - & 4)*dvd(-2)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, 5)*dvd(-3)*dvd(-3) + weno_eps + & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & + & 2)*dvd(-1)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, & + & 3)*dvd(-2)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & + & 4)*dvd(-2)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, 5)*dvd(-3)*dvd(-3) + weno_eps else ! TENO #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 ! High-Order Low-Dissipation Targeted ENO Schemes for Ideal Magnetohydrodynamics (Fu ! & Tang, 2019) Section 3.2 beta(0) = 13._wp/12._wp*(v(-1) - 2._wp*v(0) + v(1))**2._wp + ((v(-1) - v(1)) & - & **2._wp)/4._wp + weno_eps !& + & **2._wp)/4._wp + weno_eps !& beta(1) = 13._wp/12._wp*(v(0) - 2._wp*v(1) + v(2))**2._wp + ((3._wp*v(0) & - & - 4._wp*v(1) + v(2))**2._wp)/4._wp + weno_eps !& + & - 4._wp*v(1) + v(2))**2._wp)/4._wp + weno_eps !& beta(2) = 13._wp/12._wp*(v(-2) - 2._wp*v(-1) + v(0))**2._wp + ((v(-2) & - & - 4._wp*v(-1) + 3._wp*v(0))**2._wp)/4._wp + weno_eps !& + & - 4._wp*v(-1) + 3._wp*v(0))**2._wp)/4._wp + weno_eps !& beta(3) = (v(0)*(2107._wp*v(0) - 9402._wp*v(1) + 7042._wp*v(2) - 1854._wp*v(3)) & - & + v(1)*(11003._wp*v(1) - 17246._wp*v(2) + 4642._wp*v(3)) + v(2) & - & *(7043._wp*v(2) - 3882._wp*v(3)) + v(3)*(547._wp*v(3)))/240._wp + weno_eps !& + & + v(1)*(11003._wp*v(1) - 17246._wp*v(2) + 4642._wp*v(3)) + v(2) & + & *(7043._wp*v(2) - 3882._wp*v(3)) + v(3)*(547._wp*v(3)))/240._wp + weno_eps !& beta(4) = ( v(-3)*(547._wp*v(-3) - 3882._wp*v(-2) + 4642._wp*v(-1) - 1854._wp*v( 0)) & !& + v(-2)*( 7043._wp*v(-2) - 17246._wp*v(-1) + 7042._wp*v( 0)) & !& @@ -1264,17 +1206,17 @@ contains if (wenojs) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then ! Castro, et al. (2010) ! Don & Borges (2013) also helps @@ -1282,7 +1224,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbL_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability + & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability end do else if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 @@ -1306,8 +1248,7 @@ contains omega = alpha/sum(alpha) vL_rs_vf_${XYZ}$ (j, k, l, & - & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3) & - & *poly(3) + & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3)*poly(3) if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 @@ -1317,17 +1258,17 @@ contains if (.not. teno) then poly(3) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 0, & - & 0)*dvd(2) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, & - & 0, 2)*dvd(0) + & 0)*dvd(2) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, & + & 0, 2)*dvd(0) poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 1, & - & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, & - & 1, 2)*dvd(-1) + & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, & + & 1, 2)*dvd(-1) poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 2, & - & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 2, & - & 1)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 2, 2)*dvd(-2) + & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, & + & 2, 2)*dvd(-2) poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 3, & - & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 3, & - & 1)*dvd(-2) + poly_coef_cbR_${XYZ}$ (j, 3, 2)*dvd(-3) + & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 3, & + & 1)*dvd(-2) + poly_coef_cbR_${XYZ}$ (j, 3, 2)*dvd(-3) else #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 poly(0) = (-1._wp*v(-1) + 5._wp*v(0) + 2._wp*v(1))/6._wp !& @@ -1340,22 +1281,22 @@ contains if (wenojs) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbR_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability + & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability end do else if (teno) then $:GPU_LOOP(parallelism='[seq]') @@ -1367,8 +1308,7 @@ contains omega = alpha/sum(alpha) vR_rs_vf_${XYZ}$ (j, k, l, & - & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3) & - & *poly(3) + & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3)*poly(3) if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 @@ -1387,9 +1327,10 @@ contains if (int_comp) then call s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, weno_dir, & - & is1_weno_d, is2_weno_d, is3_weno_d) + & is1_weno_d, is2_weno_d, is3_weno_d) end if end subroutine s_weno + !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are required for the setup of the WENO reconstruction. !! @param v_vf Cell-averaged variables @@ -1455,6 +1396,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end subroutine s_initialize_weno + !> The goal of this subroutine is to ensure that the WENO reconstruction is monotonic. The latter is achieved by enforcing !! monotonicity preserving bounds of Suresh and Huynh (1997). The resulting MPWENO reconstruction, see Balsara and Shu (2000), !! ensures that the reconstructed values do not reside outside the range spanned by WENO stencil. @@ -1500,12 +1442,12 @@ contains d(1) = v_rs_ws(j + 2, k, l, i) + v_rs_ws(j, k, l, i) - v_rs_ws(j + 1, k, l, i)*2._wp d_MD = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1)))*abs((sign(1._wp, & - & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & - & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp + & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & + & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp d_LC = (sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, 4._wp*d(1) - d(0)))*abs((sign(1._wp, & - & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & - & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp + & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & + & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp vL_UL = v_rs_ws(j, k, l, i) - (v_rs_ws(j + 1, k, l, i) - v_rs_ws(j, k, l, i))*alpha_mp @@ -1514,14 +1456,14 @@ contains vL_LC = v_rs_ws(j, k, l, i) - (v_rs_ws(j + 1, k, l, i) - v_rs_ws(j, k, l, i))*5.e-1_wp + beta_mp*d_LC vL_min = max(min(v_rs_ws(j, k, l, i), v_rs_ws(j - 1, k, l, i), vL_MD), min(v_rs_ws(j, k, l, i), vL_UL, & - & vL_LC)) + & vL_LC)) vL_max = min(max(v_rs_ws(j, k, l, i), v_rs_ws(j - 1, k, l, i), vL_MD), max(v_rs_ws(j, k, l, i), vL_UL, & - & vL_LC)) + & vL_LC)) vL_rs_vf(j, k, l, i) = vL_rs_vf(j, k, l, i) + (sign(5.e-1_wp, vL_min - vL_rs_vf(j, k, l, & - & i)) + sign(5.e-1_wp, vL_max - vL_rs_vf(j, k, l, i)))*min(abs(vL_min - vL_rs_vf(j, k, l, i)), & - & abs(vL_max - vL_rs_vf(j, k, l, i))) + & i)) + sign(5.e-1_wp, vL_max - vL_rs_vf(j, k, l, i)))*min(abs(vL_min - vL_rs_vf(j, k, l, i)), & + & abs(vL_max - vL_rs_vf(j, k, l, i))) ! END: Left Monotonicity Preserving Bound ! Right Monotonicity Preserving Bound @@ -1530,12 +1472,12 @@ contains d(1) = v_rs_ws(j + 2, k, l, i) + v_rs_ws(j, k, l, i) - v_rs_ws(j + 1, k, l, i)*2._wp d_MD = (sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, 4._wp*d(1) - d(0)))*abs((sign(1._wp, & - & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & - & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp + & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & + & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp d_LC = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1)))*abs((sign(1._wp, & - & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & - & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp + & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & + & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp vR_UL = v_rs_ws(j, k, l, i) + (v_rs_ws(j, k, l, i) - v_rs_ws(j - 1, k, l, i))*alpha_mp @@ -1544,14 +1486,14 @@ contains vR_LC = v_rs_ws(j, k, l, i) + (v_rs_ws(j, k, l, i) - v_rs_ws(j - 1, k, l, i))*5.e-1_wp + beta_mp*d_LC vR_min = max(min(v_rs_ws(j, k, l, i), v_rs_ws(j + 1, k, l, i), vR_MD), min(v_rs_ws(j, k, l, i), vR_UL, & - & vR_LC)) + & vR_LC)) vR_max = min(max(v_rs_ws(j, k, l, i), v_rs_ws(j + 1, k, l, i), vR_MD), max(v_rs_ws(j, k, l, i), vR_UL, & - & vR_LC)) + & vR_LC)) vR_rs_vf(j, k, l, i) = vR_rs_vf(j, k, l, i) + (sign(5.e-1_wp, vR_min - vR_rs_vf(j, k, l, & - & i)) + sign(5.e-1_wp, vR_max - vR_rs_vf(j, k, l, i)))*min(abs(vR_min - vR_rs_vf(j, k, l, i)), & - & abs(vR_max - vR_rs_vf(j, k, l, i))) + & i)) + sign(5.e-1_wp, vR_max - vR_rs_vf(j, k, l, i)))*min(abs(vR_min - vR_rs_vf(j, k, l, i)), & + & abs(vR_max - vR_rs_vf(j, k, l, i))) ! END: Right Monotonicity Preserving Bound end do end do @@ -1559,6 +1501,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end subroutine s_preserve_monotonicity + !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_weno_module() if (weno_order == 1) return diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index a17827a5aa..baed0b4a2c 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -10,11 +10,8 @@ !! fraction model. program p_main use m_global_parameters !< Definitions of the global parameters - use m_start_up - use m_time_steppers - use m_nvtx implicit none @@ -71,13 +68,13 @@ program p_main if (cfl_dt) then if (mytime >= t_stop) then call s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & - & file_exists) + & file_exists) exit end if else if (t_step == t_step_stop) then call s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & - & file_exists) + & file_exists) exit end if end if From cb33f11dd9f1baf3d2ad82becc6a52247aa91bdf Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 01:42:53 -0400 Subject: [PATCH 03/25] Apply ffmt: remove bare !<, convert to !> block comments, align inline comments --- src/common/include/acc_macros.fpp | 9 +- src/common/include/macros.fpp | 3 +- src/common/include/omp_macros.fpp | 6 +- src/common/include/parallel_macros.fpp | 55 ++++-- src/common/m_boundary_common.fpp | 5 +- src/common/m_checker_common.fpp | 10 +- src/common/m_constants.fpp | 26 +-- src/common/m_derived_types.fpp | 221 ++++++++-------------- src/common/m_finite_differences.fpp | 1 - src/common/m_helper.fpp | 11 +- src/common/m_helper_basic.fpp | 3 +- src/common/m_model.fpp | 14 +- src/common/m_mpi_common.fpp | 78 +++----- src/common/m_phase_change.fpp | 17 +- src/common/m_precision_select.f90 | 2 +- src/common/m_variables_conversion.fpp | 20 +- src/post_process/m_checker.fpp | 6 +- src/post_process/m_data_input.f90 | 58 ++---- src/post_process/m_data_output.fpp | 16 +- src/post_process/m_derived_variables.fpp | 61 +++--- src/post_process/m_global_parameters.fpp | 86 ++++----- src/post_process/m_mpi_proxy.fpp | 10 +- src/post_process/m_start_up.fpp | 45 ++--- src/post_process/p_main.fpp | 18 +- src/pre_process/m_assign_variables.fpp | 18 +- src/pre_process/m_boundary_conditions.fpp | 3 +- src/pre_process/m_check_ib_patches.fpp | 70 +++++-- src/pre_process/m_check_patches.fpp | 149 ++++++++++----- src/pre_process/m_checker.fpp | 6 +- src/pre_process/m_data_output.fpp | 47 ++--- src/pre_process/m_global_parameters.fpp | 127 +++++-------- src/pre_process/m_grid.f90 | 18 +- src/pre_process/m_icpp_patches.fpp | 42 ++-- src/pre_process/m_initial_condition.fpp | 5 +- src/pre_process/m_mpi_proxy.fpp | 6 +- src/pre_process/m_perturbation.fpp | 4 +- src/pre_process/m_start_up.fpp | 70 +++---- src/pre_process/p_main.f90 | 2 +- src/simulation/m_acoustic_src.fpp | 12 +- src/simulation/m_body_forces.fpp | 6 +- src/simulation/m_bubbles.fpp | 14 +- src/simulation/m_bubbles_EE.fpp | 9 +- src/simulation/m_bubbles_EL.fpp | 27 ++- src/simulation/m_bubbles_EL_kernels.fpp | 3 +- src/simulation/m_cbc.fpp | 26 +-- src/simulation/m_checker.fpp | 37 ++-- src/simulation/m_compute_levelset.fpp | 20 +- src/simulation/m_data_output.fpp | 73 +++---- src/simulation/m_derived_variables.fpp | 15 +- src/simulation/m_fftw.fpp | 19 +- src/simulation/m_global_parameters.fpp | 78 +++----- src/simulation/m_hyperelastic.fpp | 13 +- src/simulation/m_hypoelastic.fpp | 5 +- src/simulation/m_ib_patches.fpp | 15 +- src/simulation/m_ibm.fpp | 14 +- src/simulation/m_igr.fpp | 2 +- src/simulation/m_mpi_proxy.fpp | 30 ++- src/simulation/m_muscl.fpp | 15 +- src/simulation/m_pressure_relaxation.fpp | 5 +- src/simulation/m_qbmm.fpp | 8 +- src/simulation/m_rhs.fpp | 189 +++++++++++------- src/simulation/m_riemann_solvers.fpp | 54 +++--- src/simulation/m_sim_helpers.fpp | 2 +- src/simulation/m_start_up.fpp | 66 +++---- src/simulation/m_surface_tension.fpp | 16 +- src/simulation/m_time_steppers.fpp | 147 +++++++------- src/simulation/m_viscous.fpp | 14 +- src/simulation/m_weno.fpp | 50 ++--- src/simulation/p_main.fpp | 2 +- 69 files changed, 1055 insertions(+), 1279 deletions(-) diff --git a/src/common/include/acc_macros.fpp b/src/common/include/acc_macros.fpp index f6848a103e..bd4284c01b 100644 --- a/src/common/include/acc_macros.fpp +++ b/src/common/include/acc_macros.fpp @@ -173,7 +173,8 @@ $:acc_directive #:enddef -#:def ACC_DECLARE(copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, present=None, deviceptr=None, link=None, extraAccArgs=None) +#:def ACC_DECLARE(copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, present=None, deviceptr=None, & + & link=None, extraAccArgs=None) #:set copy_val = GEN_COPY_STR(copy) #:set copyin_val = GEN_COPYIN_STR(copyin, False).strip('\n') + GEN_COPYIN_STR(copyinReadOnly, True).strip('\n') #:set copyout_val = GEN_COPYOUT_STR(copyout) @@ -190,7 +191,8 @@ $:acc_directive #:enddef -#:def ACC_LOOP(collapse=None, parallelism=None, data_dependency=None, reduction=None, reductionOp=None, private=None, extraAccArgs=None) +#:def ACC_LOOP(collapse=None, parallelism=None, data_dependency=None, reduction=None, reductionOp=None, private=None, & + & extraAccArgs=None) #:set collapse_val = GEN_COLLAPSE_STR(collapse) #:set parallelism_val = GEN_PARALLELISM_STR(parallelism) #:if data_dependency is not None @@ -211,7 +213,8 @@ $:acc_directive #:enddef -#:def ACC_DATA(code, copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, no_create=None, present=None, deviceptr=None, attach=None, default=None, extraAccArgs=None) +#:def ACC_DATA(code, copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, no_create=None, present=None, & + & deviceptr=None, attach=None, default=None, extraAccArgs=None) #:assert code is not None #:assert isinstance(code, str) #:if code == '' or code.isspace() diff --git a/src/common/include/macros.fpp b/src/common/include/macros.fpp index 3897cb88d8..44af3ac6ab 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -70,7 +70,8 @@ #:set s = a.rstrip() #:if s.endswith(')') #:set rev = s[::-1] - #:set pos = next(i for i, ch, d in ( (j, c, sum(1 if t==')' else -1 if t=='(' else 0 for t in rev[:j+1])) for j, c in enumerate(rev) ) if ch == '(' and d == 0 ) + #:set pos = next(i for i, ch, d in ( (j, c, sum(1 if t==')' else -1 if t=='(' else 0 for t in rev[:j+1])) for j, & + & c in enumerate(rev) ) if ch == '(' and d == 0 ) #:set s = s[:len(s)-1-pos] #:endif $:cleaned.append(s) diff --git a/src/common/include/omp_macros.fpp b/src/common/include/omp_macros.fpp index db25f1a81c..7620e7607f 100644 --- a/src/common/include/omp_macros.fpp +++ b/src/common/include/omp_macros.fpp @@ -241,7 +241,8 @@ #:enddef #! Not fully implemented yet (ignores most args right now) -#:def OMP_LOOP(collapse=None, parallelism=None, data_dependency=None, reduction=None, reductionOp=None, private=None, extraOmpArgs=None) +#:def OMP_LOOP(collapse=None, parallelism=None, data_dependency=None, reduction=None, reductionOp=None, private=None, & + & extraOmpArgs=None) #:if MFC_COMPILER == NVIDIA_COMPILER_ID or MFC_COMPILER == PGI_COMPILER_ID #:set omp_directive = '!$omp loop bind(thread)' #:elif MFC_COMPILER == CCE_COMPILER_ID or MFC_COMPILER == AMD_COMPILER_ID @@ -252,7 +253,8 @@ $:omp_directive #:enddef -#:def OMP_DATA(code, copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, no_create=None, present=None, deviceptr=None, attach=None, default=None, extraOmpArgs=None) +#:def OMP_DATA(code, copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, no_create=None, present=None, & + & deviceptr=None, attach=None, default=None, extraOmpArgs=None) #:assert code is not None #:assert isinstance(code, str) #:if code == '' or code.isspace() diff --git a/src/common/include/parallel_macros.fpp b/src/common/include/parallel_macros.fpp index 569af3df3a..b3b65eb9c6 100644 --- a/src/common/include/parallel_macros.fpp +++ b/src/common/include/parallel_macros.fpp @@ -6,8 +6,10 @@ & copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, & & no_create=None, present=None, deviceptr=None, attach=None, extraAccArgs=None, extraOmpArgs=None) - #:set acc_code = ACC_PARALLEL(code, private, default, firstprivate, reduction, reductionOp, copy, copyin, copyinReadOnly, copyout, create, no_create, present, deviceptr, attach, extraAccArgs) - #:set omp_code = OMP_PARALLEL(code, private, default, firstprivate, reduction, reductionOp, copy, copyin, copyinReadOnly, copyout, create, no_create, present, deviceptr, attach, extraOmpArgs) + #:set acc_code = ACC_PARALLEL(code, private, default, firstprivate, reduction, reductionOp, copy, copyin, copyinReadOnly, & + & copyout, create, no_create, present, deviceptr, attach, extraAccArgs) + #:set omp_code = OMP_PARALLEL(code, private, default, firstprivate, reduction, reductionOp, copy, copyin, copyinReadOnly, & + & copyout, create, no_create, present, deviceptr, attach, extraOmpArgs) #if defined(MFC_OpenACC) $:acc_code @@ -23,8 +25,12 @@ & copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, & & no_create=None, present=None, deviceptr=None, attach=None, extraAccArgs=None, extraOmpArgs=None) - #:set acc_directive = ACC_PARALLEL_LOOP(collapse, private, parallelism, default, firstprivate, reduction, reductionOp, copy, copyin, copyinReadOnly, copyout, create, no_create, present, deviceptr, attach, extraAccArgs) - #:set omp_directive = OMP_PARALLEL_LOOP(collapse, private, parallelism, default, firstprivate, reduction, reductionOp, copy, copyin, copyinReadOnly, copyout, create, no_create, present, deviceptr, attach, extraOmpArgs) + #:set acc_directive = ACC_PARALLEL_LOOP(collapse, private, parallelism, default, firstprivate, reduction, reductionOp, copy, & + & copyin, copyinReadOnly, copyout, create, no_create, present, deviceptr, attach, & + & extraAccArgs) + #:set omp_directive = OMP_PARALLEL_LOOP(collapse, private, parallelism, default, firstprivate, reduction, reductionOp, copy, & + & copyin, copyinReadOnly, copyout, create, no_create, present, deviceptr, attach, & + & extraOmpArgs) #if defined(MFC_OpenACC) $:acc_directive @@ -44,11 +50,13 @@ #endif #:enddef -#:def GPU_ROUTINE(function_name=None, parallelism=None, nohost=False, cray_inline=False, cray_noinline=False, extraAccArgs=None, extraOmpArgs=None) +#:def GPU_ROUTINE(function_name=None, parallelism=None, nohost=False, cray_inline=False, cray_noinline=False, extraAccArgs=None, & + & extraOmpArgs=None) #:assert isinstance(cray_inline, bool) #:assert isinstance(cray_noinline, bool) #:assert not (cray_inline and cray_noinline), "cray_inline and cray_noinline are mutually exclusive" - #:set acc_directive = ACC_ROUTINE(function_name=function_name, parallelism=parallelism, nohost=nohost, extraAccArgs=extraAccArgs) + #:set acc_directive = ACC_ROUTINE(function_name=function_name, parallelism=parallelism, nohost=nohost, & + & extraAccArgs=extraAccArgs) #:set omp_directive = OMP_ROUTINE(function_name=function_name, nohost=nohost, extraOmpArgs=extraOmpArgs) #:if cray_noinline == True @@ -98,8 +106,10 @@ #:endif #:enddef -#:def GPU_DECLARE(copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, present=None, deviceptr=None, link=None, extraAccArgs=None, extraOmpArgs=None) - #:set acc_code = ACC_DECLARE(copy=copy, copyin=copyin, copyinReadOnly=copyinReadOnly, copyout=copyout, create=create, present=present, deviceptr=deviceptr, link=link, extraAccArgs=None) +#:def GPU_DECLARE(copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, present=None, deviceptr=None, & + & link=None, extraAccArgs=None, extraOmpArgs=None) + #:set acc_code = ACC_DECLARE(copy=copy, copyin=copyin, copyinReadOnly=copyinReadOnly, copyout=copyout, create=create, & + & present=present, deviceptr=deviceptr, link=link, extraAccArgs=None) #:assert copyout is None #:assert present is None #:assert deviceptr is None @@ -113,9 +123,12 @@ #endif #:enddef -#:def GPU_LOOP(collapse=None, parallelism=None, data_dependency=None, reduction=None, reductionOp=None, private=None, extraAccArgs=None, extraOmpArgs=None) - #:set acc_code = ACC_LOOP(collapse=collapse, parallelism=parallelism, data_dependency=data_dependency, reduction=reduction, reductionOp=reductionOp, private=private, extraAccArgs=extraAccArgs) - #:set omp_code = OMP_LOOP(collapse=collapse, parallelism=parallelism, data_dependency=data_dependency, reduction=reduction, reductionOp=reductionOp, private=private, extraOmpArgs=extraOmpArgs) +#:def GPU_LOOP(collapse=None, parallelism=None, data_dependency=None, reduction=None, reductionOp=None, private=None, & + & extraAccArgs=None, extraOmpArgs=None) + #:set acc_code = ACC_LOOP(collapse=collapse, parallelism=parallelism, data_dependency=data_dependency, reduction=reduction, & + & reductionOp=reductionOp, private=private, extraAccArgs=extraAccArgs) + #:set omp_code = OMP_LOOP(collapse=collapse, parallelism=parallelism, data_dependency=data_dependency, reduction=reduction, & + & reductionOp=reductionOp, private=private, extraOmpArgs=extraOmpArgs) #if defined(MFC_OpenACC) $:acc_code @@ -124,9 +137,14 @@ #endif #:enddef -#:def GPU_DATA(code, copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, no_create=None, present=None, deviceptr=None, attach=None, default=None, extraAccArgs=None, extraOmpArgs=None) - #:set acc_code = ACC_DATA(code=code, copy=copy, copyin=copyin, copyinReadOnly=copyinReadOnly, copyout=copyout, create=create, no_create=no_create, present=present, deviceptr=deviceptr, attach=attach, default=default, extraAccArgs=extraAccArgs) - #:set omp_code = OMP_DATA(code=code, copy=copy, copyin=copyin, copyinReadOnly=copyinReadOnly, copyout=copyout, create=create, no_create=no_create, present=present, deviceptr=deviceptr, attach=attach, default=default, extraOmpArgs=extraOmpArgs) +#:def GPU_DATA(code, copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, no_create=None, present=None, & + & deviceptr=None, attach=None, default=None, extraAccArgs=None, extraOmpArgs=None) + #:set acc_code = ACC_DATA(code=code, copy=copy, copyin=copyin, copyinReadOnly=copyinReadOnly, copyout=copyout, create=create, & + & no_create=no_create, present=present, deviceptr=deviceptr, attach=attach, default=default, & + & extraAccArgs=extraAccArgs) + #:set omp_code = OMP_DATA(code=code, copy=copy, copyin=copyin, copyinReadOnly=copyinReadOnly, copyout=copyout, create=create, & + & no_create=no_create, present=present, deviceptr=deviceptr, attach=attach, default=default, & + & extraOmpArgs=extraOmpArgs) #if defined(MFC_OpenACC) $:acc_code @@ -153,7 +171,8 @@ #:set use_device = None #:endif #:set acc_code = ACC_HOST_DATA(code=code, use_device=use_device, extraAccArgs=extraAccArgs) - #:set omp_code = OMP_HOST_DATA(code=code, use_device_addr=use_device_addr, use_device_ptr=use_device_ptr, extraOmpArgs=extraOmpArgs) + #:set omp_code = OMP_HOST_DATA(code=code, use_device_addr=use_device_addr, use_device_ptr=use_device_ptr, & + & extraOmpArgs=extraOmpArgs) #if defined(MFC_OpenACC) $:acc_code @@ -165,8 +184,10 @@ #:enddef #:def GPU_ENTER_DATA(copyin=None, copyinReadOnly=None, create=None, attach=None, extraAccArgs=None, extraOmpArgs=None) - #:set acc_code = ACC_ENTER_DATA(copyin=copyin, copyinReadOnly=copyinReadOnly, create=create, attach=attach, extraAccArgs=extraAccArgs) - #:set omp_code = OMP_ENTER_DATA(copyin=copyin, copyinReadOnly=copyinReadOnly, create=create, attach=attach, extraOmpArgs=extraOmpArgs) + #:set acc_code = ACC_ENTER_DATA(copyin=copyin, copyinReadOnly=copyinReadOnly, create=create, attach=attach, & + & extraAccArgs=extraAccArgs) + #:set omp_code = OMP_ENTER_DATA(copyin=copyin, copyinReadOnly=copyinReadOnly, create=create, attach=attach, & + & extraOmpArgs=extraOmpArgs) #if defined(MFC_OpenACC) $:acc_code diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 18c07b49a4..dd87622ebb 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -7,8 +7,8 @@ #:include 'macros.fpp' module m_boundary_common - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_mpi_proxy use m_constants use m_delay_file_access @@ -1808,7 +1808,6 @@ contains !! locations and cell-width distributions, based on the boundary conditions. subroutine s_populate_grid_variables_buffers integer :: i !< Generic loop iterator - #ifdef MFC_SIMULATION ! Required for compatibility between codes type(int_bounds_info) :: offset_x, offset_y, offset_z diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index 48c4b7b2de..0bc507f4a2 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -7,9 +7,9 @@ !> @brief Shared input validation checks for grid dimensions and AMD GPU compiler limits module m_checker_common - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none @@ -37,7 +37,9 @@ contains min_cells = int(2, kind=8)**int(min(1, m) + min(1, n) + min(1, p), kind=8)*int(num_procs, kind=8) call s_int_to_str(2**(min(1, m) + min(1, n) + min(1, p))*num_procs, numStr) - @:PROHIBIT(nGlobal < min_cells, "Total number of cells must be at least (2^[number of dimensions])*num_procs, " // "which is currently "//trim(numStr)) + @:PROHIBIT(nGlobal < min_cells, & + & "Total number of cells must be at least (2^[number of dimensions])*num_procs, " // "which is currently " & + & // trim(numStr)) end subroutine s_check_total_cells #endif diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index 47298914b1..bd3e352dde 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -13,9 +13,8 @@ module m_constants real(wp), parameter :: small_alf = 1.e-11_wp !< Small alf tolerance real(wp), parameter :: pi = 3.141592653589793_wp !< Pi real(wp), parameter :: verysmall = 1.e-12_wp !< Very small number - real(wp), & - & parameter :: small_radius = 1.e-32_wp !< Radius cutoff to avoid division by zero for 3D spherical harmonic patch (geometry 14) - + !> Radius cutoff to avoid division by zero for 3D spherical harmonic patch (geometry 14) + real(wp), parameter :: small_radius = 1.e-32_wp integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils integer, parameter :: path_len = 400 !< Maximum path length integer, parameter :: name_len = 50 !< Maximum name length @@ -33,25 +32,22 @@ module m_constants integer, parameter :: dflt_num_igr_warm_start_iters = 50 !< default number of iterations for IGR elliptic solve real(wp), parameter :: dflt_alf_factor = 10._wp !< scaling factor for IGR alpha integer, parameter :: gp_layers = 3 !< Number of ghost point layers for IBM - real(wp), & - & parameter :: capillary_cutoff = 1.e-6 !< color function gradient magnitude at which to apply the surface tension fluxes - real(wp), & - & parameter :: acoustic_spatial_support_width = 2.5_wp !< Spatial support width of acoustic source, used in s_source_spatial + !> color function gradient magnitude at which to apply the surface tension fluxes + real(wp), parameter :: capillary_cutoff = 1.e-6 + !> Spatial support width of acoustic source, used in s_source_spatial + real(wp), parameter :: acoustic_spatial_support_width = 2.5_wp real(wp), parameter :: dflt_vcfl_dt = 100._wp !< value of vcfl_dt when viscosity is off for computing adaptive timestep size - real(wp), & - & parameter :: broadband_spectral_level_constant = 20._wp !< The constant to scale the spectral level at the lower frequency bound - real(wp), & - & parameter :: broadband_spectral_level_growth_rate = 10._wp !< The spectral level constant to correct the magnitude at each frequency to ensure the source is overall broadband - + !> The constant to scale the spectral level at the lower frequency bound + real(wp), parameter :: broadband_spectral_level_constant = 20._wp + !> The spectral level constant to correct the magnitude at each frequency to ensure the source is overall broadband + real(wp), parameter :: broadband_spectral_level_growth_rate = 10._wp ! Reconstruction Types integer, parameter :: WENO_TYPE = 1 !< Using WENO for reconstruction type integer, parameter :: MUSCL_TYPE = 2 !< Using MUSCL for reconstruction type - ! Interface Compression real(wp), parameter :: dflt_ic_eps = 1e-4_wp !< Ensure compression is only applied to surface cells in THINC real(wp), parameter :: dflt_ic_beta = 1.6_wp !< Sharpness parameter's default value used in THINC real(wp), parameter :: moncon_cutoff = 1e-8_wp !< Monotonicity constraint's limiter to prevent extremas in THINC - ! Chemistry real(wp), parameter :: dflt_T_guess = 1200._wp ! Default guess for temperature (when a previous value is not available) @@ -61,7 +57,6 @@ module m_constants real(wp), parameter :: threshold_vector_zero = 1.e-10_wp !< Threshold to treat the component of a vector to be zero real(wp), parameter :: threshold_edge_zero = 1.e-10_wp !< Threshold to treat two edges to be overlapped real(wp), parameter :: initial_distance_buffer = 1.e12_wp !< Initialized levelset distance for the shortest path pair algorithm - ! Lagrange bubbles constants integer, parameter :: mapCells = 3 !< Number of cells around the bubble where the smoothening function will have effect real(wp), parameter :: R_uni = 8314._wp !< Universal gas constant - J/kmol/K @@ -70,7 +65,6 @@ module m_constants ! Strang Splitting constants real(wp), parameter :: dflt_adap_dt_tol = 1.e-4_wp !< Default tolerance for adaptive step size integer, parameter :: dflt_adap_dt_max_iters = 100 !< Default max iteration for adaptive step size - ! Constants of the algorithm described by Heirer, E. Hairer, S. P.Norsett, G. Wanner, Solving Ordinary Differential Equations I, ! Chapter II.4 ! to choose the initial time step size for the adaptive time stepping routine diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 5870f87c1f..948803e75d 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -6,7 +6,7 @@ !> @brief Shared derived types for field data, patch geometry, bubble dynamics, and MPI I/O structures module m_derived_types - use m_constants !< Constants + use m_constants !< Constants use m_precision_select use m_thermochem, only: num_species @@ -137,24 +137,12 @@ module m_derived_types !> Defines parameters for a Model Patch type ic_model_parameters - character(LEN=pathlen_max) :: filepath !< - !! Path the STL file relative to case_dir. - - real(wp), dimension(1:3) :: translate !< - !! Translation of the STL object. - - real(wp), dimension(1:3) :: scale !< - !! Scale factor for the STL object. - - real(wp), dimension(1:3) :: rotate !< - !! Angle to rotate the STL object along each cartesian coordinate axis, - !! in radians. - - integer :: spc !< - !! Number of samples per cell to use when discretizing the STL object. - - real(wp) :: threshold !< - !! Threshold to turn on smoothen STL patch. + character(LEN=pathlen_max) :: filepath !< Path the STL file relative to case_dir. + real(wp), dimension(1:3) :: translate !< Translation of the STL object. + real(wp), dimension(1:3) :: scale !< Scale factor for the STL object. + real(wp), dimension(1:3) :: rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + integer :: spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: threshold !< Threshold to turn on smoothen STL patch. end type ic_model_parameters type :: t_triangle @@ -197,156 +185,105 @@ module m_derived_types !! patch geometry. type ic_patch_parameters - integer :: geometry !< Type of geometry for the patch - real(wp) :: x_centroid, y_centroid, z_centroid !< - !! Location of the geometric center, i.e. the centroid, of the patch. It - !! is specified through its x-, y- and z-coordinates, respectively. - - real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. - real(wp), dimension(3) :: radii !< - !! Vector indicating the various radii for the elliptical and ellipsoidal - !! patch geometries. It is specified through its x-, y-, and z-components + integer :: geometry !< Type of geometry for the patch + !> Location of the geometric center, i.e. the centroid, of the patch. It is specified through its x-, y- and z-coordinates, !! respectively. - - real(wp) :: epsilon, beta !< - !! The isentropic vortex parameters for the amplitude of the disturbance and - !! domain of influence. - - real(wp), dimension(2:9) :: a !< - !! Used by hardcoded IC and as temporary variables. - - logical :: non_axis_sym + real(wp) :: x_centroid, y_centroid, z_centroid + real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. + real(wp) :: radius !< Dimensions of the patch. radius. + !> Vector indicating the various radii for the elliptical and ellipsoidal patch geometries. It is specified through its x-, + !! y-, and z-components respectively. + real(wp), dimension(3) :: radii + real(wp) :: epsilon, beta !< The isentropic vortex parameters for the amplitude of the disturbance and domain of influence. + real(wp), dimension(2:9) :: a !< Used by hardcoded IC and as temporary variables. + logical :: non_axis_sym ! Geometry 13 (2D modal Fourier): fourier_cos(n), fourier_sin(n) for mode n real(wp), dimension(1:max_2d_fourier_modes) :: fourier_cos, fourier_sin logical :: modal_clip_r_to_min !< When true, clip boundary radius: R(theta) = max(R(theta), modal_r_min) (Non-exp form only) - real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) - logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) - + real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) + logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) ! Geometry 14 (3D spherical harmonic): sph_har_coeff(l,m) for real Y_lm real(wp), dimension(0:max_sph_harm_degree, -max_sph_harm_degree:max_sph_harm_degree) :: sph_har_coeff - real(wp), dimension(3) :: normal !< - !! Normal vector indicating the orientation of the patch. It is specified - !! through its x-, y- and z-components, respectively. - - logical, dimension(0:num_patches_max - 1) :: alter_patch !< - - !! List of permissions that indicate to the current patch which preceding - !! patches it is allowed to overwrite when it is in process of being laid - !! out in the domain - - logical :: smoothen !< - !! Permission indicating to the current patch whether its boundaries will - !! be smoothed out across a few cells or whether they are to remain sharp - - integer :: smooth_patch_id !< - !! Identity (id) of the patch with which current patch is to get smoothed - - real(wp) :: smooth_coeff !< - !! Smoothing coefficient (coeff) for the size of the stencil of - !! cells across which boundaries of the current patch will be smeared out - + !> Normal vector indicating the orientation of the patch. It is specified through its x-, y- and z-components, respectively. + real(wp), dimension(3) :: normal + !> List of permissions that indicate to the current patch which preceding patches it is allowed to overwrite when it is in + !! process of being laid out in the domain + logical, dimension(0:num_patches_max - 1) :: alter_patch + !> Permission indicating to the current patch whether its boundaries will be smoothed out across a few cells or whether they + !! are to remain sharp + logical :: smoothen + integer :: smooth_patch_id !< Identity (id) of the patch with which current patch is to get smoothed + !> Smoothing coefficient (coeff) for the size of the stencil of cells across which boundaries of the current patch will be + !! smeared out + real(wp) :: smooth_coeff real(wp), dimension(num_fluids_max) :: alpha_rho real(wp) :: rho real(wp), dimension(3) :: vel real(wp) :: pres real(wp), dimension(num_fluids_max) :: alpha real(wp) :: gamma - real(wp) :: pi_inf !< - real(wp) :: cv !< - real(wp) :: qv !< - real(wp) :: qvp !< - - !! Primitive variables associated with the patch. In order, these include - !! the partial densities, density, velocity, pressure, volume fractions, - !! specific heat ratio function and the liquid stiffness function. - real(wp) :: Bx, By, Bz !< - !! Magnetic field components; B%x is not used for 1D - - real(wp), dimension(6) :: tau_e !< - !! Elastic stresses added to primitive variables if hypoelasticity = True - - real(wp) :: R0 !< Bubble size - real(wp) :: V0 !< Bubble velocity - real(wp) :: p0 !< Bubble size - real(wp) :: m0 !< Bubble velocity - integer :: hcid + real(wp) :: pi_inf + real(wp) :: cv + real(wp) :: qv + !> Primitive variables associated with the patch. In order, these include the partial densities, density, velocity, + !! pressure, volume fractions, specific heat ratio function and the liquid stiffness function. + real(wp) :: qvp + real(wp) :: Bx, By, Bz !< Magnetic field components; B%x is not used for 1D + real(wp), dimension(6) :: tau_e !< Elastic stresses added to primitive variables if hypoelasticity = True + real(wp) :: R0 !< Bubble size + real(wp) :: V0 !< Bubble velocity + real(wp) :: p0 !< Bubble size + real(wp) :: m0 !< Bubble velocity + integer :: hcid !! id for hard coded initial condition real(wp) :: cf_val !! color function value real(wp) :: Y(1:num_species) !! STL or OBJ model input parameter - character(LEN=pathlen_max) :: model_filepath !< - !! Path the STL file relative to case_dir. - - real(wp), dimension(1:3) :: model_translate !< - !! Translation of the STL object. - - real(wp), dimension(1:3) :: model_scale !< - !! Scale factor for the STL object. - - real(wp), dimension(1:3) :: model_rotate !< - !! Angle to rotate the STL object along each cartesian coordinate axis, - !! in radians. - - integer :: model_spc !< - !! Number of samples per cell to use when discretizing the STL object. - - real(wp) :: model_threshold !< - !! Threshold to turn on smoothen STL patch. + character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. + real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. + real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. + real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. end type ic_patch_parameters type ib_patch_parameters - integer :: geometry !< Type of geometry for the patch - real(wp) :: x_centroid, y_centroid, z_centroid !< - !! Location of the geometric center, i.e. the centroid, of the patch. It - !! is specified through its x-, y- and z-coordinates, respectively. - real(wp) :: step_x_centroid, step_y_centroid, step_z_centroid !< - !! Centroid locations of intermediate steps in the time_stepper module + integer :: geometry !< Type of geometry for the patch + !> Location of the geometric center, i.e. the centroid, of the patch. It is specified through its x-, y- and z-coordinates, + !! respectively. + real(wp) :: x_centroid, y_centroid, z_centroid + !> Centroid locations of intermediate steps in the time_stepper module + real(wp) :: step_x_centroid, step_y_centroid, step_z_centroid real(wp), dimension(1:3) :: centroid_offset ! offset of center of mass from computed cell center for odd-shaped IBs real(wp), dimension(1:3) :: angles real(wp), dimension(1:3) :: step_angles real(wp), dimension(1:3, 1:3) :: rotation_matrix !< matrix that converts from IB reference frame to fluid reference frame - real(wp), dimension(1:3, & - & 1:3) :: rotation_matrix_inverse !< matrix that converts from fluid reference frame to IB reference frame - - real(wp) :: c, p, t, m - real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. - real(wp) :: theta - logical :: slip + !> matrix that converts from fluid reference frame to IB reference frame + real(wp), dimension(1:3, 1:3) :: rotation_matrix_inverse + real(wp) :: c, p, t, m + real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. + real(wp) :: radius !< Dimensions of the patch. radius. + real(wp) :: theta + logical :: slip !! STL or OBJ model input parameter - character(LEN=pathlen_max) :: model_filepath !< - !! Path the STL file relative to case_dir. - - real(wp), dimension(1:3) :: model_translate !< - !! Translation of the STL object. - - real(wp), dimension(1:3) :: model_scale !< - !! Scale factor for the STL object. - - real(wp), dimension(1:3) :: model_rotate !< - !! Angle to rotate the STL object along each cartesian coordinate axis, - !! in radians. - - integer :: model_spc !< - !! Number of samples per cell to use when discretizing the STL object. - - real(wp) :: model_threshold !< - !! Threshold to turn on smoothen STL patch. - - !! Patch conditions for moving imersed boundaries - integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path - real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling - real(wp), dimension(1:3) :: force, torque ! vectors for the computed force and torque values applied to an IB - real(wp), dimension(1:3) :: vel - real(wp), dimension(1:3) :: step_vel ! velocity array used to store intermediate steps in the time_stepper module - real(wp), dimension(1:3) :: angular_vel - real(wp), dimension(1:3) :: step_angular_vel ! velocity array used to store intermediate steps in the time_stepper module + character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. + real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. + real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. + real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. Patch conditions for moving imersed boundaries + integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path + real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling + real(wp), dimension(1:3) :: force, torque ! vectors for the computed force and torque values applied to an IB + real(wp), dimension(1:3) :: vel + real(wp), dimension(1:3) :: step_vel ! velocity array used to store intermediate steps in the time_stepper module + real(wp), dimension(1:3) :: angular_vel + real(wp), dimension(1:3) :: step_angular_vel ! velocity array used to store intermediate steps in the time_stepper module end type ib_patch_parameters !> Derived type annexing the physical parameters (PP) of the fluids. These include the specific heat ratio function and liquid @@ -419,8 +356,8 @@ module m_derived_types real(wp) :: foc_length ! < Focal length of transducer real(wp) :: aperture ! < Aperture diameter of transducer real(wp) :: element_spacing_angle !< Spacing between aperture elements in 2D acoustic array - real(wp) & - & :: element_polygon_ratio !< Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array + !> Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array + real(wp) :: element_polygon_ratio real(wp) :: rotate_angle !< Angle of rotation of the entire circular 3D acoustic array real(wp) :: bb_bandwidth !< Bandwidth of each frequency in broadband wave real(wp) :: bb_lowest_freq !< The lower frequency bound of broadband wave diff --git a/src/common/m_finite_differences.fpp b/src/common/m_finite_differences.fpp index 651691ce9e..9d1dc83788 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -84,7 +84,6 @@ contains real(wp), allocatable, dimension(:,:), intent(inout) :: fd_coeff_s real(wp), dimension(-local_buff_size:q + local_buff_size), intent(in) :: s_cc integer :: i !< Generic loop iterator - if (present(offset_s)) then lB = -offset_s%beg lE = q + offset_s%end diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index 0c8b99ceb7..34e2d02f7e 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -7,10 +7,9 @@ !> @brief Utility routines for bubble model setup, coordinate transforms, array sampling, and special functions module m_helper - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use ieee_arithmetic !< For checking NaN - + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use ieee_arithmetic !< For checking NaN implicit none private; @@ -161,9 +160,7 @@ contains impure subroutine s_initialize_nonpoly() integer :: ir real(wp), dimension(nb) :: chi_vw0, cp_m0, k_m0, rho_m0, x_vw, omegaN, rhol0 - real(wp), parameter :: k_poly = 1._wp !< - !! polytropic index used to compute isothermal natural frequency - + real(wp), parameter :: k_poly = 1._wp !< polytropic index used to compute isothermal natural frequency ! phi_vg & phi_gv (phi_gg = phi_vv = 1) (Eq. 2.22 in Ando 2010) phi_vg = (1._wp + sqrt(mu_v/mu_g)*(M_g/M_v)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_v/M_g)) phi_gv = (1._wp + sqrt(mu_g/mu_v)*(M_v/M_g)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_g/M_v)) diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 79d8fc16bf..39aca7b7a5 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -6,8 +6,7 @@ !> @brief Basic floating-point utilities: approximate equality, default detection, and coordinate bounds module m_helper_basic - use m_derived_types !< Definitions of the derived types - + use m_derived_types !< Definitions of the derived types implicit none private; diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index d0c2dca6a4..40a46533e8 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -644,14 +644,13 @@ contains type(t_model), intent(in) :: model real(wp), allocatable, intent(out), dimension(:,:,:) :: boundary_v !< Output boundary vertices/normals integer, intent(out) :: boundary_vertex_count, boundary_edge_count !< Output boundary vertex/edge count - integer :: i, j !< Model index iterator - integer :: edge_count, edge_index, store_index !< Boundary edge index iterator - real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer - real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer + integer :: i, j !< Model index iterator + integer :: edge_count, edge_index, store_index !< Boundary edge index iterator + real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer + real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer real(wp), dimension(1:(3*model%ntrs), 1:2, 1:2) :: temp_boundary_v !< Temporary boundary vertex buffer - integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges - real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges - + integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges + real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges ! Total number of edges in 2D STL edge_count = 3*model%ntrs @@ -755,7 +754,6 @@ contains integer, intent(inout) :: edge_count !< Total number of edges real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered real(wp), dimension(1:edge_count, 1:2, 1:2), intent(inout) :: temp_boundary_v !< Temporary edge end vertex buffer - ! Increment edge index and store the edge edge_index = edge_index + 1 temp_boundary_v(edge_index, 1, 1:2) = edge(1, 1:2) diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 0de48a15b6..0caece3da4 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -8,11 +8,11 @@ !> @brief MPI communication layer: domain decomposition, halo exchange, reductions, and parallel I/O setup module m_mpi_common #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_helper use ieee_arithmetic use m_nvtx @@ -23,16 +23,12 @@ module m_mpi_common $:GPU_DECLARE(create='[v_size]') !! Generic flags used to identify and report MPI errors - real(wp), private, allocatable, dimension(:) :: buff_send !< - !! This variable is utilized to pack and send the buffer of the cell-average - !! primitive variables, for a single computational domain boundary at the - !! time, to the relevant neighboring processor. - - real(wp), private, allocatable, dimension(:) :: buff_recv !< - !! buff_recv is utilized to receive and unpack the buffer of the cell- - !! average primitive variables, for a single computational domain boundary - !! at the time, from the relevant neighboring processor. - + !> This variable is utilized to pack and send the buffer of the cell-average primitive variables, for a single computational + !! domain boundary at the time, to the relevant neighboring processor. + real(wp), private, allocatable, dimension(:) :: buff_send + !> buff_recv is utilized to receive and unpack the buffer of the cell- average primitive variables, for a single computational + !! domain boundary at the time, from the relevant neighboring processor. + real(wp), private, allocatable, dimension(:) :: buff_recv #ifndef __NVCOMPILER_GPU_UNIFIED_MEM $:GPU_DECLARE(create='[buff_send, buff_recv]') #endif @@ -83,7 +79,6 @@ contains impure subroutine s_mpi_initialize #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Initializing the MPI environment call MPI_INIT(ierr) @@ -121,7 +116,6 @@ contains ! Generic loop iterator integer :: i, j integer :: ierr !< Generic flag used to identify and report MPI errors - ! Altered system size for the lagrangian subgrid bubble model integer :: alt_sys @@ -274,7 +268,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - call MPI_GATHER(time_avg, 1, mpi_p, proc_time(0), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif end subroutine mpi_bcast_time_step_values @@ -316,7 +309,6 @@ contains #ifdef MFC_SIMULATION #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Reducing local extrema of ICFL, VCFL, CCFL and Rc numbers to their ! global extrema and bookkeeping the results on the rank 0 processor call MPI_REDUCE(icfl_max_loc, icfl_max_glb, 1, mpi_p, MPI_MAX, 0, MPI_COMM_WORLD, ierr) @@ -348,7 +340,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) #endif @@ -363,7 +354,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure if (loc(var_loc) == loc(var_glb)) then call MPI_Allreduce(MPI_IN_PLACE, var_glb, num_vectors*vector_length, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -386,7 +376,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) #else @@ -405,7 +394,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, MPI_COMM_WORLD, ierr) #endif @@ -422,7 +410,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MAX, MPI_COMM_WORLD, ierr) #endif @@ -437,7 +424,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Temporary storage variable that holds the reduced minimum value real(wp) :: var_glb @@ -461,11 +447,10 @@ contains real(wp), dimension(2), intent(inout) :: var_loc #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors - real(wp), dimension(2) :: var_glb !< - !! Temporary storage variable that holds the reduced maximum value - !! and the rank of the processor with which the value is associated - + integer :: ierr !< Generic flag used to identify and report MPI errors + !> Temporary storage variable that holds the reduced maximum value and the rank of the processor with which the value is + !! associated + real(wp), dimension(2) :: var_glb ! Performing reduction procedure and eventually storing its result ! into the variable that was initially inputted into the subroutine call MPI_REDUCE(var_loc, var_glb, 1, mpi_2p, MPI_MAXLOC, 0, MPI_COMM_WORLD, ierr) @@ -512,7 +497,6 @@ contains impure subroutine s_mpi_barrier #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Calling MPI_BARRIER call MPI_BARRIER(MPI_COMM_WORLD, ierr) #endif @@ -522,7 +506,6 @@ contains impure subroutine s_mpi_finalize #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Finalizing the MPI environment call MPI_FINALIZE(ierr) #endif @@ -550,7 +533,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - call nvtxStartRange("RHS-COMM-PACKBUF") qbmm_comm = .false. @@ -958,28 +940,17 @@ contains subroutine s_mpi_decompose_computational_domain #ifdef MFC_MPI - integer :: num_procs_x, num_procs_y, num_procs_z !< - !! Optimal number of processors in the x-, y- and z-directions - - real(wp) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z !< - !! Non-optimal number of processors in the x-, y- and z-directions - - real(wp) :: fct_min !< - !! Processor factorization (fct) minimization parameter - - integer :: MPI_COMM_CART !< - !! Cartesian processor topology communicator - - integer :: rem_cells !< - !! Remaining number of cells, in a particular coordinate direction, - !! after the majority is divided up among the available processors - - integer :: recon_order !< - !! WENO or MUSCL reconstruction order - - integer :: i, j !< Generic loop iterators - integer :: ierr !< Generic flag used to identify and report MPI errors - + integer :: num_procs_x, num_procs_y, num_procs_z !< Optimal number of processors in the x-, y- and z-directions + !> Non-optimal number of processors in the x-, y- and z-directions + real(wp) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z + real(wp) :: fct_min !< Processor factorization (fct) minimization parameter + integer :: MPI_COMM_CART !< Cartesian processor topology communicator + !> Remaining number of cells, in a particular coordinate direction, after the majority is divided up among the available + !! processors + integer :: rem_cells + integer :: recon_order !< WENO or MUSCL reconstruction order + integer :: i, j !< Generic loop iterators + integer :: ierr !< Generic flag used to identify and report MPI errors if (recon_type == WENO_TYPE) then recon_order = weno_order else @@ -1397,7 +1368,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! MPI Communication in x-direction if (mpi_dir == 1) then if (pbc_loc == -1) then ! PBC at the beginning diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index 49d6685499..c8bd4fe20c 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -9,13 +9,12 @@ module m_phase_change #ifndef MFC_POST_PROCESS - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures use ieee_arithmetic - use m_helper_basic !< Functions to compare floating point numbers - + use m_helper_basic !< Functions to compare floating point numbers implicit none private; @@ -67,12 +66,12 @@ contains subroutine s_infinite_relaxation_k(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid - real(wp) :: TS, TSOV, TSSL, TSatOV, & - & TSatSL !< equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor and subcooled liquid + !> equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor + !! and subcooled liquid + real(wp) :: TS, TSOV, TSSL, TSatOV, TSatSL real(wp) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy real(wp) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses real(wp) :: TvF !< total volume fraction - ! $:GPU_DECLARE(create='[pS,pSOV,pSSL,TS,TSOV,TSSL,TSatOV,TSatSL]') ! $:GPU_DECLARE(create='[rhoe,dynE,rhos,rho,rM,m1,m2,MCT,TvF]') #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -279,7 +278,6 @@ contains real(wp) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver real(wp) :: p_infpT_sum integer :: i, ns !< generic loop iterators - ! auxiliary variables for the pT-equilibrium solver mCP = 0.0_wp; mQ = 0.0_wp; p_infpT_sum = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -600,7 +598,6 @@ contains real(wp), intent(out) :: TSat real(wp), intent(in) :: TSIn real(wp) :: dFdT, FT, Om !< auxiliary variables - ! Generic loop iterators integer :: ns diff --git a/src/common/m_precision_select.f90 b/src/common/m_precision_select.f90 index 51809bb069..ac96bfc9e8 100644 --- a/src/common/m_precision_select.f90 +++ b/src/common/m_precision_select.f90 @@ -6,7 +6,7 @@ module m_precision_select ! use, intrinsic :: iso_c_binding #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif implicit none diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 16bb266de9..232ea7815f 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -7,10 +7,10 @@ !> @brief Conservative-to-primitive variable conversion, mixture property evaluation, and pressure computation module m_variables_conversion - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_helper use m_thermochem, only: num_species, get_temperature, get_pressure, gas_constant, get_mixture_molecular_weight, & & get_mixture_energy_mass @@ -117,7 +117,6 @@ contains real(wp) :: e_Per_Kg, Pdyn_Per_Kg real(wp) :: T_guess integer :: s !< Generic loop iterator - #:if not chemistry ! Depending on model_eqns and bubbles_euler, the appropriate procedure ! for computing pressure is targeted by the procedure pointer @@ -217,10 +216,9 @@ contains real(wp), intent(out), target :: qv real(wp), optional, dimension(2), intent(out) :: Re_K real(wp), optional, intent(out) :: G_K - real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K !< + real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K real(wp), optional, dimension(num_fluids), intent(in) :: G - integer :: i, j !< Generic loop iterator - + integer :: i, j !< Generic loop iterator ! Computing the density, the specific heat ratio function and the ! liquid stiffness function, respectively call s_compute_species_fraction(q_vf, k, l, r, alpha_rho_K, alpha_K) @@ -282,17 +280,16 @@ contains real(wp), intent(out) :: rho_K, gamma_K, pi_inf_K, qv_K #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3), intent(inout) :: alpha_rho_K, alpha_K !< + real(wp), dimension(3), intent(inout) :: alpha_rho_K, alpha_K real(wp), optional, dimension(3), intent(in) :: G #:else - real(wp), dimension(num_fluids), intent(inout) :: alpha_rho_K, alpha_K !< + real(wp), dimension(num_fluids), intent(inout) :: alpha_rho_K, alpha_K real(wp), optional, dimension(num_fluids), intent(in) :: G #:endif real(wp), dimension(2), intent(out) :: Re_K real(wp), optional, intent(out) :: G_K real(wp) :: alpha_K_sum integer :: i, j !< Generic loop iterators - #ifdef MFC_SIMULATION ! Constraining the partial densities and the volume fractions within ! their physical bounds to make sure that any mixture variables that @@ -1084,7 +1081,6 @@ contains real(wp) :: G_K real(wp) :: T_K, mix_mol_weight, R_gas integer :: i, j, k, l !< Generic loop iterators - is1b = is1%beg; is1e = is1%end is2b = is2%beg; is2e = is2%end is3b = is3%beg; is3e = is3%end diff --git a/src/post_process/m_checker.fpp b/src/post_process/m_checker.fpp index ff0be224a5..0d3f8c39a3 100644 --- a/src/post_process/m_checker.fpp +++ b/src/post_process/m_checker.fpp @@ -6,9 +6,9 @@ !> @brief Validates post-process input parameters and output format consistency module m_checker - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index 4477e325a9..d5a3bece57 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -5,12 +5,12 @@ !> @brief Reads raw simulation grid and conservative-variable data for a given time-step and fills buffer regions module m_data_input #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_mpi_common use m_compile_specific use m_boundary_common @@ -32,19 +32,11 @@ impure subroutine s_read_abstract_data_files(t_step) end subroutine s_read_abstract_data_files end interface - type(scalar_field), allocatable, dimension(:), public :: q_cons_vf !< - !! Conservative variables - - type(scalar_field), allocatable, dimension(:), public :: q_cons_temp - type(scalar_field), allocatable, dimension(:), public :: q_prim_vf !< - !! Primitive variables - - type(integer_field), allocatable, dimension(:,:), public :: bc_type !< - !! Boundary condition identifiers - - type(scalar_field), public :: q_T_sf !< - !! Temperature field - + type(scalar_field), allocatable, dimension(:), public :: q_cons_vf !< Conservative variables + type(scalar_field), allocatable, dimension(:), public :: q_cons_temp + type(scalar_field), allocatable, dimension(:), public :: q_prim_vf !< Primitive variables + type(integer_field), allocatable, dimension(:,:), public :: bc_type !< Boundary condition identifiers + type(scalar_field), public :: q_T_sf !< Temperature field ! type(scalar_field), public :: ib_markers !< type(integer_field), public :: ib_markers @@ -207,27 +199,15 @@ end subroutine s_allocate_field_arrays !! @param t_step Current time-step impure subroutine s_read_serial_data_files(t_step) integer, intent(in) :: t_step - character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_dir !< - !! Location of the time-step directory associated with t_step - - character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc !< - !! Generic string used to store the location of a particular file - - character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< - !! Used to store the variable position, in character form, of the - !! currently manipulated conservative variable file - - character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_ib_dir !< - !! Location of the time-step directory associated with t_step - - logical :: dir_check !< - !! Generic logical used to test the existence of a particular folder - - logical :: file_check !< - !! Generic logical used to test the existence of a particular file - - integer :: i !< Generic loop iterator - + character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_dir !< Location of the time-step directory associated with t_step + character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc !< Generic string used to store the location of a particular file + !> Used to store the variable position, in character form, of the currently manipulated conservative variable file + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num + !> Location of the time-step directory associated with t_step + character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_ib_dir + logical :: dir_check !< Generic logical used to test the existence of a particular folder + logical :: file_check !< Generic logical used to test the existence of a particular file + integer :: i !< Generic loop iterator ! Setting location of time-step folder based on current time-step write (t_step_dir, '(A,I0,A,I0)') '/p_all/p', proc_rank, '/', t_step t_step_dir = trim(case_dir) // trim(t_step_dir) @@ -532,7 +512,6 @@ end subroutine s_read_parallel_conservative_data !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_data_input_module integer :: i !< Generic loop iterator - ! Allocating the parts of the conservative and primitive variables ! that do not require the direct knowledge of the dimensionality of ! the simulation @@ -587,7 +566,6 @@ end subroutine s_initialize_data_input_module !> Deallocation procedures for the module impure subroutine s_finalize_data_input_module integer :: i !< Generic loop iterator - ! Deallocating the conservative and primitive variables do i = 1, sys_size deallocate (q_cons_vf(i)%sf) diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index e285fdc1ab..cadf5a245e 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -6,7 +6,7 @@ module m_data_output use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters - use m_derived_variables !< Procedures used to compute quantities derived + use m_derived_variables !< Procedures used to compute quantities derived use m_mpi_proxy ! Message passing interface (MPI) module proxy use m_compile_specific use m_helper @@ -433,7 +433,6 @@ contains ! Generic string used to store the location of a particular file character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc integer :: ierr !< Generic flag used to identify and report database errors - ! Silo-HDF5 Database Format if (format == 1) then @@ -522,9 +521,7 @@ contains !> @brief Open the interface data file for appending extracted interface coordinates. impure subroutine s_open_intf_data_file() - character(LEN=path_len + 3*name_len) :: file_path !< - !! Relative path to a file in the case directory - + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to a file in the case directory write (file_path, '(A)') '/intf_data.dat' file_path = trim(case_dir) // trim(file_path) @@ -534,9 +531,7 @@ contains !> @brief Open the energy data file for appending volume-integrated energy budget quantities. impure subroutine s_open_energy_data_file() - character(LEN=path_len + 3*name_len) :: file_path !< - !! Relative path to a file in the case directory - + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to a file in the case directory write (file_path, '(A)') '/eng_data.dat' file_path = trim(case_dir) // trim(file_path) @@ -577,7 +572,6 @@ contains ! Generic loop iterator integer :: i integer :: ierr !< Generic flag used to identify and report database errors - ! Silo-HDF5 Database Format if (format == 1) then @@ -750,7 +744,6 @@ contains ! Generic loop iterator integer :: i, j, k integer :: ierr !< Generic flag used to identify and report database errors - ! Silo-HDF5 Database Format if (format == 1) then @@ -1340,7 +1333,7 @@ contains impure subroutine s_write_intf_data_file(q_prim_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf integer :: i, j, k, l, cent !< Generic loop iterators - integer :: counter, root !< number of data points extracted to fit shape to SH perturbations + integer :: counter, root !< number of data points extracted to fit shape to SH perturbations real(wp), allocatable :: x_td(:), y_td(:), x_d1(:), y_d1(:), y_d(:), x_d(:) real(wp) :: axp, axm, ayp, aym, tgp, euc_d, thres, maxalph_loc, maxalph_glb @@ -1526,7 +1519,6 @@ contains ! not generated. integer :: ierr !< Generic flag used to identify and report database errors - ! Silo-HDF5 database format if (format == 1) then ierr = DBCLOSE(dbfile) diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 8ce4d51acb..a3f88626e9 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -5,10 +5,10 @@ !> @brief Computes derived flow quantities (sound speed, vorticity, Schlieren, etc.) from conservative and primitive variables module m_derived_variables - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_variables_conversion implicit none @@ -17,11 +17,9 @@ module m_derived_variables & 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 !< - !! Gradient magnitude (gm) of the density for each cell of the computational - !! sub-domain. This variable is employed in the calculation of the numerical - !! Schlieren function. - + !> Gradient magnitude (gm) of the density for each cell of the computational sub-domain. This variable is employed in the + !! calculation of the numerical Schlieren function. + real(wp), allocatable, dimension(:,:,:) :: gm_rho_sf !> @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. @@ -31,14 +29,12 @@ module m_derived_variables real(wp), allocatable, dimension(:,:), public :: fd_coeff_z !> @} - integer, private :: flg !< - !! Flagging (flg) variable used to annotate the dimensionality of the dataset - !! that is undergoing the post-process. A flag value of 1 indicates that the - !! dataset is 3D, while a flag value of 0 indicates that it is not. This flg - !! variable is necessary to avoid cycling through the third dimension of the - !! flow variable(s) when the simulation is not 3D and the size of the buffer - !! is non-zero. Note that a similar procedure does not have to be applied to - !! the second dimension since in 1D, the buffer size is always zero. + !> Flagging (flg) variable used to annotate the dimensionality of the dataset that is undergoing the post-process. A flag value + !! of 1 indicates that the dataset is 3D, while a flag value of 0 indicates that it is not. This flg variable is necessary to + !! avoid cycling through the third dimension of the flow variable(s) when the simulation is not 3D and the size of the buffer is + !! non-zero. Note that a similar procedure does not have to be applied to the second dimension since in 1D, the buffer size is + !! always zero. + integer, private :: flg contains !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module @@ -90,7 +86,6 @@ contains & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators - ! Computing specific heat ratio from specific heat ratio function do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end @@ -110,7 +105,6 @@ contains & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators - ! Calculating the values of the liquid stiffness from those of the ! specific heat ratio function and the liquid stiffness function do k = -offset_z%beg, p + offset_z%end @@ -134,7 +128,6 @@ contains & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators - ! Fluid bulk modulus for alternate sound speed real(wp) :: blkmod1, blkmod2 @@ -179,7 +172,6 @@ contains real(wp) :: top, bottom, slope !< Flux limiter calcs integer :: j, k, l !< Generic loop iterators - do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end @@ -301,7 +293,6 @@ contains & intent(inout) :: q_sf integer :: j, k, l, r !< Generic loop iterators - ! Computing the vorticity component in the x-coordinate direction if (i == 1) then do l = -offset_z%beg, p + offset_z%end @@ -373,7 +364,6 @@ contains real(wp), dimension(1:3, 1:3) :: q_jacobian_sf, S, S2, O, O2 real(wp) :: trS, Q, IIS integer :: j, k, l, r, jj, kk !< Generic loop iterators - do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end @@ -427,12 +417,12 @@ contains integer, parameter :: nm = 3 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + !> Liutex magnitude real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(out) :: liutex_mag !< Liutex magnitude - + & intent(out) :: liutex_mag + !> Liutex rigid rotation axis real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, nm), & - & intent(out) :: liutex_axis !< Liutex rigid rotation axis - + & intent(out) :: liutex_axis character, parameter :: ivl = 'N' !< compute left eigenvectors character, parameter :: ivr = 'V' !< compute right eigenvectors real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor @@ -531,17 +521,12 @@ contains real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - real(wp) :: drho_dx, drho_dy, drho_dz !< - !! Spatial derivatives of the density in the x-, y- and z-directions - - real(wp), dimension(2) :: gm_rho_max !< - !! Maximum value of the gradient magnitude (gm) of the density field - !! in entire computational domain and not just the local sub-domain. - !! The first position in the variable contains the maximum value and - !! the second contains the rank of the processor on which it occurred. - - integer :: i, j, k, l !< Generic loop iterators - + real(wp) :: drho_dx, drho_dy, drho_dz !< Spatial derivatives of the density in the x-, y- and z-directions + !> Maximum value of the gradient magnitude (gm) of the density field in entire computational domain and not just the local + !! sub-domain. The first position in the variable contains the maximum value and the second contains the rank of the + !! processor on which it occurred. + real(wp), dimension(2) :: gm_rho_max + integer :: i, j, k, l !< Generic loop iterators ! Computing Gradient Magnitude of Density ! Contributions from the x- and y-coordinate directions diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index fe1ffad39d..2518ab1505 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -7,11 +7,11 @@ !> @brief Global parameters for the post-process: domain geometry, equation of state, and output database settings module m_global_parameters #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types !< Definitions of the derived types + use m_helper_basic !< Functions to compare floating point numbers use m_thermochem, only: num_species, species_names implicit none @@ -25,7 +25,6 @@ module m_global_parameters ! Computational Domain Parameters integer :: proc_rank !< Rank of the local processor - !> @name Number of cells in the x-, y- and z-coordinate directions !> @{ integer :: m, m_root @@ -50,7 +49,6 @@ module m_global_parameters integer :: num_dims !< Number of spatial dimensions integer :: num_vels !< Number of velocity components (different from num_dims for mhd) - !> @name Cell-boundary locations in the x-, y- and z-coordinate directions !> @{ real(wp), allocatable, dimension(:) :: x_cb, x_root_cb, y_cb, z_cb @@ -67,15 +65,12 @@ module m_global_parameters real(wp), allocatable, dimension(:) :: dx, dy, dz !> @} - integer :: buff_size !< - !! Number of cells in buffer region. For the variables which feature a buffer - !! region, this region is used to store information outside the computational - !! domain based on the boundary conditions. - + !> Number of cells in buffer region. For the variables which feature a buffer region, this region is used to store information + !! outside the computational domain based on the boundary conditions. + integer :: buff_size integer :: t_step_start !< First time-step directory integer :: t_step_stop !< Last time-step directory integer :: t_step_save !< Interval between consecutive time-step directory - !> @name IO options for adaptive time-stepping !> @{ logical :: cfl_adap_dt, cfl_const_dt, cfl_dt @@ -117,8 +112,7 @@ module m_global_parameters logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling !> @} - integer :: avg_state !< Average state evaluation method - + integer :: avg_state !< Average state evaluation method !> @name Annotations of the structure, i.e. the organization, of the state vectors !> @{ type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. @@ -157,25 +151,17 @@ module m_global_parameters !> @} integer :: shear_num !! Number of shear stress components - integer, dimension(3) :: shear_indices !< - !! Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< - !! Number of shear stress components to reflect for boundary conditions - integer, dimension(3, 2) :: shear_BC_flip_indices !< - !! Indices of shear stress components to reflect for boundary conditions. - !! Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, [indices]) - + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, + !! [indices]) + integer, dimension(3, 2) :: shear_BC_flip_indices logical :: parallel_io !< Format of the data files logical :: sim_data logical :: file_per_process !< output format - integer, allocatable, dimension(:) :: proc_coords !< - !! Processor coordinates in MPI_CART_COMM - - integer, allocatable, dimension(:) :: start_idx !< - !! Starting cell-center index of local processor in global grid - - integer :: num_ibs !< Number of immersed boundaries - + integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM + integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid + integer :: num_ibs !< Number of immersed boundaries #ifdef MFC_MPI type(mpi_io_var), public :: MPI_IO_DATA @@ -191,15 +177,12 @@ module m_global_parameters integer :: mpi_info_int !> @} - type(physical_parameters), dimension(num_fluids_max) :: fluid_pp !< - !! Database of the physical parameters of each of the fluids that is present - !! in the flow. These include the stiffened gas equation of state parameters, - !! and the Reynolds numbers. - + !> Database of the physical parameters of each of the fluids that is present in the flow. These include the stiffened gas + !! equation of state parameters, and the Reynolds numbers. + type(physical_parameters), dimension(num_fluids_max) :: fluid_pp ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp real(wp), allocatable, dimension(:) :: adv !< Advection variables - ! Formatted Database File(s) Structure Parameters integer :: format !< Format of the database file(s) @@ -208,7 +191,6 @@ module m_global_parameters logical :: output_partial_domain !< Specify portion of domain to output for post-processing type(bounds_info) :: x_output, y_output, z_output !< Portion of domain to output for post-processing type(int_bounds_info) :: x_output_idx, y_output_idx, z_output_idx !< Indices of domain to output for post-processing - !> @name Size of the ghost zone layer in the x-, y- and z-coordinate directions. The definition of the ghost zone layers is only !! necessary when using the Silo database file format in multidimensions. These zones provide VisIt with the subdomain !! connectivity information that it requires in order to produce smooth plots. @@ -230,7 +212,9 @@ module m_global_parameters logical :: E_wrt logical, dimension(num_fluids_max) :: alpha_rho_e_wrt logical :: fft_wrt - logical :: dummy !< AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional is false + !> AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional + !! is false + logical :: dummy logical :: pres_wrt logical, dimension(num_fluids_max) :: alpha_wrt logical :: gamma_wrt @@ -269,21 +253,16 @@ module m_global_parameters logical :: lag_betaC_wrt !> @} - real(wp), dimension(num_fluids_max) :: schlieren_alpha !< - !! Amplitude coefficients of the numerical Schlieren function that are used - !! to adjust the intensity of numerical Schlieren renderings for individual - !! fluids. This enables waves and interfaces of varying strengths and in all - !! of the fluids to be made simultaneously visible on a single plot. - - integer :: fd_order !< - !! The order of the finite-difference (fd) approximations of the first-order - !! derivatives that need to be evaluated when vorticity and/or the numerical - !! Schlieren function are to be outputted to the formatted database file(s). - integer :: fd_number !< - !! The finite-difference number is given by MAX(1, fd_order/2). Essentially, - !! it is a measure of the half-size of the finite-difference stencil for the - !! selected order of accuracy. - + !> Amplitude coefficients of the numerical Schlieren function that are used to adjust the intensity of numerical Schlieren + !! renderings for individual fluids. This enables waves and interfaces of varying strengths and in all of the fluids to be made + !! simultaneously visible on a single plot. + real(wp), dimension(num_fluids_max) :: schlieren_alpha + !> The order of the finite-difference (fd) approximations of the first-order derivatives that need to be evaluated when + !! vorticity and/or the numerical Schlieren function are to be outputted to the formatted database file(s). + integer :: fd_order + !> The finite-difference number is given by MAX(1, fd_order/2). Essentially, it is a measure of the half-size of the + !! finite-difference stencil for the selected order of accuracy. + integer :: fd_number !> @name Reference parameters for Tait EOS !> @{ real(wp) :: rhoref, pref @@ -300,7 +279,7 @@ module m_global_parameters logical :: polytropic logical :: polydisperse logical :: adv_n - integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer + integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl real(wp) :: gam_m real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g @@ -344,7 +323,6 @@ contains !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs integer :: i !< Generic loop iterator - ! Logistics case_dir = '.' diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index 674e34ea05..c15e25f0d4 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -5,11 +5,11 @@ !> @brief MPI gather and scatter operations for distributing post-process grid and flow-variable data module m_mpi_proxy #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code use m_mpi_common use ieee_arithmetic @@ -29,7 +29,6 @@ contains integer :: i !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors - ! Allocating and configuring the receive counts and the displacement ! vector variables used in variable-gather communication procedures. ! Note that these are only needed for either multidimensional runs @@ -61,7 +60,6 @@ contains #ifdef MFC_MPI integer :: i !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors - ! Logistics call MPI_BCAST(case_dir, len(case_dir), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) @@ -231,7 +229,6 @@ contains impure subroutine s_mpi_defragment_1d_grid_variable #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Silo-HDF5 database format if (format == 1) then call MPI_GATHERV(x_cc(0), m + 1, mpi_p, x_root_cc(0), recvcounts, displs, mpi_p, 0, MPI_COMM_WORLD, ierr) @@ -291,7 +288,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Gathering the sub-domain flow variable data from all the processes ! and putting it back together for the entire computational domain ! on the process with rank 0 diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 73bf851ab9..2376e95585 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -11,22 +11,15 @@ module m_start_up use, intrinsic :: iso_c_binding - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_mpi_common !< Common MPI subroutines - use m_boundary_common !< Common boundary conditions subroutines - use m_variables_conversion !< Subroutines to change the state variables from - !! one form to another - - use m_data_input !< Procedures reading raw simulation data to fill - !! the conservative, primitive and grid variables - - use m_data_output !< Procedures that write the grid and chosen flow - !! variable(s) to the formatted database file(s) - - use m_derived_variables !< Procedures used to compute quantities derived - !! from the conservative and primitive variables + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_common !< Common MPI subroutines + use m_boundary_common !< Common boundary conditions subroutines + use m_variables_conversion !< Subroutines to change the state variables from one form to another + use m_data_input !< Procedures reading raw simulation data to fill the conservative, primitive and grid variables + use m_data_output !< Procedures that write the grid and chosen flow variable(s) to the formatted database file(s) + use m_derived_variables !< Procedures used to compute quantities derived from the conservative and primitive variables use m_helper use m_compile_specific use m_checker_common @@ -36,7 +29,7 @@ module m_start_up use m_chemistry #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif implicit none @@ -60,13 +53,9 @@ contains !> Reads the configuration file post_process.inp, in order to populate parameters in module m_global_parameters.f90 with the !! user provided inputs impure subroutine s_read_input_file - character(LEN=name_len) :: file_loc !< - !! Generic string used to store the address of a particular file - - logical :: file_check !< - !! Generic logical used for the purpose of asserting whether a file - !! is or is not present in the designated location - + character(LEN=name_len) :: file_loc !< Generic string used to store the address of a particular file + !> Generic logical used for the purpose of asserting whether a file is or is not present in the designated location + logical :: file_check integer :: iostatus !! Integer to check iostat of file read @@ -133,12 +122,8 @@ contains !> Checking that the user inputs make sense, i.e. that the individual choices are compatible with the code's options and that !! the combination of these choices results into a valid configuration for the post-process impure subroutine s_check_input_file - character(LEN=len_trim(case_dir)) :: file_loc !< - !! Generic string used to store the address of a particular file - - logical :: dir_check !< - !! Logical variable used to test the existence of folders - + character(LEN=len_trim(case_dir)) :: file_loc !< Generic string used to store the address of a particular file + logical :: dir_check !< Logical variable used to test the existence of folders ! Checking the existence of the case folder case_dir = adjustl(case_dir) diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index a8ae0c0092..01a1c7ed34 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -7,20 +7,18 @@ !! of the primitive and conservative variables, as well as quantities that can be derived from those such as the unadvected volume !! fraction, specific heat ratio, liquid stiffness, speed of sound, vorticity and the numerical Schlieren function. program p_main - use m_global_parameters !< Global parameters for the code + use m_global_parameters !< Global parameters for the code use m_start_up implicit none - integer :: t_step !< Iterator for the main time-stepping loop - character(LEN=name_len) :: varname !< - !! Generic storage for the name(s) of the flow variable(s) that will be added - !! to the formatted database file(s) - - real(wp) :: pres - real(wp) :: c - real(wp) :: H - real(wp) :: start, finish + integer :: t_step !< Iterator for the main time-stepping loop + !> Generic storage for the name(s) of the flow variable(s) that will be added to the formatted database file(s) + character(LEN=name_len) :: varname + real(wp) :: pres + real(wp) :: c + real(wp) :: H + real(wp) :: start, finish call s_initialize_mpi_domain() diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index 39b2a53164..60a482b85f 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -10,7 +10,7 @@ module m_assign_variables use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code use m_variables_conversion ! Subroutines to change the state variables from - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_thermochem, only: num_species, gas_constant, get_mixture_molecular_weight implicit none @@ -19,10 +19,9 @@ module m_assign_variables type(scalar_field) :: alf_sum - procedure(s_assign_patch_xxxxx_primitive_variables), pointer :: s_assign_patch_primitive_variables => null() !< - !! Depending on the multicomponent flow model, this variable is a pointer to - !! either the subroutine s_assign_patch_mixture_primitive_variables, or the - !! subroutine s_assign_patch_species_primitive_variables + !> Depending on the multicomponent flow model, this variable is a pointer to either the subroutine + !! s_assign_patch_mixture_primitive_variables, or the subroutine s_assign_patch_species_primitive_variables + procedure(s_assign_patch_xxxxx_primitive_variables), pointer :: s_assign_patch_primitive_variables => null() !> Abstract interface to the two subroutines that assign the patch primitive variables, either mixture or species, depending on !! the subroutine, to a particular cell in the computational domain abstract interface @@ -100,7 +99,6 @@ contains real(wp) :: Ys(1:num_species) integer :: smooth_patch_id integer :: i !< generic loop operator - ! Assigning the mixture primitive variables of a uniform state patch ! Transferring the identity of the smoothing patch @@ -266,11 +264,9 @@ contains real(wp) :: rcoord, theta, phi, xi_sph real(wp), dimension(3) :: xi_cart real(wp) :: Ys(1:num_species) - real(stp), dimension(sys_size) :: orig_prim_vf !< - !! Vector to hold original values of cell for smoothing purposes - - integer :: i !< Generic loop iterator - integer :: smooth_patch_id + real(stp), dimension(sys_size) :: orig_prim_vf !< Vector to hold original values of cell for smoothing purposes + integer :: i !< Generic loop iterator + integer :: smooth_patch_id ! Transferring the identity of the smoothing patch smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index 21dc3c99fe..d3c169aa91 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -18,8 +18,7 @@ module m_boundary_conditions real(wp) :: x_centroid, y_centroid, z_centroid real(wp) :: length_x, length_y, length_z real(wp) :: radius - type(bounds_info) :: x_boundary, y_boundary, z_boundary !< - + type(bounds_info) :: x_boundary, y_boundary, z_boundary private; public :: s_apply_boundary_patches contains !> @brief Applies a line-segment boundary condition patch along a domain edge in 2D. diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index 8a8603070e..2c1ba59b05 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -7,18 +7,16 @@ #:include 'macros.fpp' module m_check_ib_patches - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Procedures to write the grid data and the - !! conservative variables to files - + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_data_output !< Procedures to write the grid data and the conservative variables to files #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_compile_specific - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none @@ -63,7 +61,9 @@ contains & "patch_ib(" // trim(iStr) // ")%geometry must be " // "2-4, 8-10, 11 or 12.") end if else - @:PROHIBIT(patch_ib(i)%geometry /= dflt_int, "Inactive IB patch defined. "// "patch_ib("//trim(iStr)//")%geometry must not be set for inactive patches.") + @:PROHIBIT(patch_ib(i)%geometry /= dflt_int, & + & "Inactive IB patch defined. " // "patch_ib(" // trim(iStr) & + & // ")%geometry must not be set for inactive patches.") call s_check_inactive_ib_patch_geometry(i) end if end do @@ -76,7 +76,8 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%radius <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in circle IB patch '//trim(iStr)) + @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%radius <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) & + & .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in circle IB patch ' // trim(iStr)) end subroutine s_check_circle_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the ellipse patch have consistently been inputted by the user. @@ -86,7 +87,9 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in ellipse IB patch '//trim(iStr)) + @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id) & + & %length_y <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & + & %y_centroid), 'in ellipse IB patch ' // trim(iStr)) end subroutine s_check_ellipse_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the airfoil patch have consistently been inputted by the user. @@ -96,7 +99,9 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id)%p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in airfoil IB patch '//trim(iStr)) + @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id)%p <= 0._wp .or. patch_ib(patch_id) & + & %t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) & + & .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in airfoil IB patch ' // trim(iStr)) end subroutine s_check_airfoil_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the 3d airfoil patch have consistently been inputted by the user. @@ -106,7 +111,11 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p == 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id)%p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. f_is_default(patch_ib(patch_id)%length_z), 'in 3d airfoil IB patch '//trim(iStr)) + @:PROHIBIT(n == 0 .or. p == 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id) & + & %p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id) & + & %m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) & + & .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. f_is_default(patch_ib(patch_id)%length_z), & + & 'in 3d airfoil IB patch ' // trim(iStr)) end subroutine s_check_3d_airfoil_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the rectangle patch have consistently been inputted by the user. @@ -116,7 +125,9 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p > 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp, 'in rectangle IB patch '//trim(iStr)) + @:PROHIBIT(n == 0 .or. p > 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & + & %y_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp, & + & 'in rectangle IB patch ' // trim(iStr)) end subroutine s_check_rectangle_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the sphere patch have consistently been inputted by the user. @@ -126,7 +137,9 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%radius <= 0._wp, 'in sphere IB patch '//trim(iStr)) + @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & + & %y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%radius <= 0._wp, & + & 'in sphere IB patch ' // trim(iStr)) end subroutine s_check_sphere_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the cuboid patch have consistently been inputted by the user. @@ -136,7 +149,10 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. patch_ib(patch_id)%length_z <= 0._wp, 'in cuboid IB patch '//trim(iStr)) + @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & + & %y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id) & + & %length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. patch_ib(patch_id)%length_z <= 0._wp, & + & 'in cuboid IB patch ' // trim(iStr)) end subroutine s_check_cuboid_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the cylinder patch have consistently been inputted by the user. @@ -146,9 +162,17 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT(p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. (patch_ib(patch_id)%length_x <= 0._wp .and. patch_ib(patch_id)%length_y <= 0._wp .and. patch_ib(patch_id)%length_z <= 0._wp) .or. patch_ib(patch_id)%radius <= 0._wp, 'in cylinder IB patch '//trim(iStr)) - - @:PROHIBIT( (patch_ib(patch_id)%length_x > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_y)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id)%length_y > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id)%length_z > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_y)))), 'in cylinder IB patch '//trim(iStr)) + @:PROHIBIT(p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) & + & .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. (patch_ib(patch_id) & + & %length_x <= 0._wp .and. patch_ib(patch_id)%length_y <= 0._wp .and. patch_ib(patch_id)%length_z <= 0._wp) & + & .or. patch_ib(patch_id)%radius <= 0._wp, 'in cylinder IB patch ' // trim(iStr)) + + @:PROHIBIT((patch_ib(patch_id)%length_x > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_y)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id) & + & %length_y > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id) & + & %length_z > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%length_y)))), 'in cylinder IB patch ' // trim(iStr)) end subroutine s_check_cylinder_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the model patch have consistently been inputted by the user. @@ -160,7 +184,8 @@ contains @:PROHIBIT(patch_ib(patch_id)%model_filepath == dflt_char, 'Empty model file path for patch '//trim(iStr)) - @:PROHIBIT(patch_ib(patch_id)%model_scale(1) <= 0._wp .or. patch_ib(patch_id)%model_scale(2) <= 0._wp .or. patch_ib(patch_id)%model_scale(3) <= 0._wp, 'Negative scale in model IB patch '//trim(iStr)) + @:PROHIBIT(patch_ib(patch_id)%model_scale(1) <= 0._wp .or. patch_ib(patch_id)%model_scale(2) & + & <= 0._wp .or. patch_ib(patch_id)%model_scale(3) <= 0._wp, 'Negative scale in model IB patch ' // trim(iStr)) end subroutine s_check_model_ib_patch_geometry !!> This subroutine verifies that the geometric parameters of @@ -171,6 +196,9 @@ contains call s_int_to_str(patch_id, iStr) - @:PROHIBIT((.not. f_is_default(patch_ib(patch_id)%x_centroid)) .or. (.not. f_is_default(patch_ib(patch_id)%y_centroid)) .or. (.not. f_is_default(patch_ib(patch_id)%z_centroid)) .or. (.not. f_is_default(patch_ib(patch_id)%length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_y)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)) .or. (.not. f_is_default(patch_ib(patch_id)%radius)), 'in inactive IB patch '//trim(iStr)) + @:PROHIBIT((.not. f_is_default(patch_ib(patch_id)%x_centroid)) .or. (.not. f_is_default(patch_ib(patch_id)%y_centroid)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%z_centroid)) .or. (.not. f_is_default(patch_ib(patch_id) %length_x)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%length_y)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%radius)), 'in inactive IB patch ' // trim(iStr)) end subroutine s_check_inactive_ib_patch_geometry end module m_check_ib_patches diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 5e50457bc8..44a5170fa7 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -10,18 +10,16 @@ module m_check_patches ! Dependencies - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Procedures to write the grid data and the - !! conservative variables to files - + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_data_output !< Procedures to write the grid data and the conservative variables to files #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_compile_specific - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none @@ -42,10 +40,14 @@ contains if (i <= num_patches) then ! call s_check_patch_geometry(i) call s_int_to_str(i, iStr) - @:PROHIBIT(patch_icpp(i)%geometry == 6, "Invalid patch geometry number. "// "patch_icpp("//trim(iStr)//")%geometry is deprecated.") - @:PROHIBIT(patch_icpp(i)%geometry == 7, "Invalid patch geometry number. "// "patch_icpp("//trim(iStr)//")%geometry is deprecated.") - @:PROHIBIT(patch_icpp(i)%geometry == 15, "Invalid patch geometry number. "// "patch_icpp("//trim(iStr)//")%geometry is deprecated.") - @:PROHIBIT(patch_icpp(i)%geometry == dflt_int, "Invalid patch geometry number. "// "patch_icpp("//trim(iStr)//")%geometry must be set.") + @:PROHIBIT(patch_icpp(i)%geometry == 6, & + & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") + @:PROHIBIT(patch_icpp(i)%geometry == 7, & + & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") + @:PROHIBIT(patch_icpp(i)%geometry == 15, & + & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") + @:PROHIBIT(patch_icpp(i)%geometry == dflt_int, & + & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry must be set.") ! Constraints on the geometric initial condition patch parameters if (patch_icpp(i)%geometry == 1) then @@ -81,7 +83,9 @@ contains & "patch_icpp(" // trim(iStr) // ")%geometry " // "must be between 1 and 21") end if else - @:PROHIBIT(patch_icpp(i)%geometry /= dflt_int, "Inactive patch defined. "// "patch_icpp("//trim(iStr)//")%geometry not be set for inactive patches. "// "Patch "//trim(iStr)//" is inactive as the number of patches is "//trim(num_patches_str)) + @:PROHIBIT(patch_icpp(i)%geometry /= dflt_int, & + & "Inactive patch defined. " // "patch_icpp(" // trim(iStr) // ")%geometry not be set for inactive patches. " & + & // "Patch " // trim(iStr) // " is inactive as the number of patches is " // trim(num_patches_str)) call s_check_inactive_patch_geometry(i) end if end do @@ -124,7 +128,8 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(n > 0, "Line segment patch "//trim(iStr)//": n must be zero") - @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Line segment patch "//trim(iStr)//": length_x must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, & + & "Line segment patch " // trim(iStr) // ": length_x must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Line segment patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(cyl_coord, "Line segment patch "//trim(iStr)//": cyl_coord is not supported") end subroutine s_check_line_segment_patch_geometry @@ -168,7 +173,8 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Line sweep patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(1)), "Line sweep patch "//trim(iStr)//": normal(1) must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(2)), "Line sweep patch "//trim(iStr)//": normal(2) must be set") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%normal(3)), "Line sweep patch "//trim(iStr)//": normal(3) must not be set") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%normal(3)), & + & "Line sweep patch " // trim(iStr) // ": normal(3) must not be set") end subroutine s_check_line_sweep_patch_geometry !> This subroutine checks the ellipse patch input @@ -194,11 +200,16 @@ contains @:PROHIBIT(n == 0, "Taylor Green vortex patch "//trim(iStr)//": n must be greater than zero") @:PROHIBIT(p > 0, "Taylor Green vortex patch "//trim(iStr)//": p must be zero") - @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Taylor Green vortex patch "//trim(iStr)//": x_centroid must be set") - @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Taylor Green vortex patch "//trim(iStr)//": y_centroid must be set") - @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Taylor Green vortex patch "//trim(iStr)//": length_x must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Taylor Green vortex patch "//trim(iStr)//": length_y must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%vel(2) <= 0._wp, "Taylor Green vortex patch "//trim(iStr)//": vel(2) must be greater than zero") + @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), & + & "Taylor Green vortex patch " // trim(iStr) // ": x_centroid must be set") + @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), & + & "Taylor Green vortex patch " // trim(iStr) // ": y_centroid must be set") + @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, & + & "Taylor Green vortex patch " // trim(iStr) // ": length_x must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, & + & "Taylor Green vortex patch " // trim(iStr) // ": length_y must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%vel(2) <= 0._wp, & + & "Taylor Green vortex patch " // trim(iStr) // ": vel(2) must be greater than zero") end subroutine s_check_2D_TaylorGreen_vortex_patch_geometry !> This subroutine checks the model patch input @@ -232,10 +243,14 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Spherical harmonic patch "//trim(iStr)//": p must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "Spherical harmonic patch "//trim(iStr)//": radius must be greater than zero") - @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Spherical harmonic patch "//trim(iStr)//": x_centroid must be set") - @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Spherical harmonic patch "//trim(iStr)//": y_centroid must be set") - @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Spherical harmonic patch "//trim(iStr)//": z_centroid must be set") + @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, & + & "Spherical harmonic patch " // trim(iStr) // ": radius must be greater than zero") + @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), & + & "Spherical harmonic patch " // trim(iStr) // ": x_centroid must be set") + @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), & + & "Spherical harmonic patch " // trim(iStr) // ": y_centroid must be set") + @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), & + & "Spherical harmonic patch " // trim(iStr) // ": z_centroid must be set") end subroutine s_check_3d_spherical_harmonic_patch_geometry !> This subroutine checks the model patch input @@ -268,10 +283,15 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "Cylinder patch "//trim(iStr)//": radius must be greater than zero") ! Check if exactly one length is defined - @:PROHIBIT(count([ patch_icpp(patch_id)%length_x > 0._wp, patch_icpp(patch_id)%length_y > 0._wp, patch_icpp(patch_id)%length_z > 0._wp ]) /= 1, "Cylinder patch "//trim(iStr)//": Exactly one of length_x, length_y, or length_z must be defined and positive") + @:PROHIBIT(count([patch_icpp(patch_id)%length_x > 0._wp, patch_icpp(patch_id)%length_y > 0._wp, & + & patch_icpp(patch_id)%length_z > 0._wp]) /= 1, & + & "Cylinder patch " // trim(iStr) // ": Exactly one of length_x, length_y, or length_z must be defined and positive") ! Ensure the defined length is positive - @:PROHIBIT( (.not. f_is_default(patch_icpp(patch_id)%length_x) .and. patch_icpp(patch_id)%length_x <= 0._wp) .or. (.not. f_is_default(patch_icpp(patch_id)%length_y) .and. patch_icpp(patch_id)%length_y <= 0._wp) .or. (.not. f_is_default(patch_icpp(patch_id)%length_z) .and. patch_icpp(patch_id)%length_z <= 0._wp), "Cylinder patch "//trim(iStr)//": The defined length_{} must be greater than zero") + @:PROHIBIT((.not. f_is_default(patch_icpp(patch_id)%length_x) .and. patch_icpp(patch_id)%length_x <= 0._wp) & + & .or. (.not. f_is_default(patch_icpp(patch_id)%length_y) .and. patch_icpp(patch_id)%length_y <= 0._wp) & + & .or. (.not. f_is_default(patch_icpp(patch_id)%length_z) .and. patch_icpp(patch_id)%length_z <= 0._wp), & + & "Cylinder patch " // trim(iStr) // ": The defined length_{} must be greater than zero") end subroutine s_check_cylinder_patch_geometry !> This subroutine checks the model patch input @@ -312,9 +332,12 @@ contains integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%x_centroid), "Inactive patch "//trim(iStr)//": x_centroid must not be set") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%y_centroid), "Inactive patch "//trim(iStr)//": y_centroid must not be set") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%z_centroid), "Inactive patch "//trim(iStr)//": z_centroid must not be set") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%x_centroid), & + & "Inactive patch " // trim(iStr) // ": x_centroid must not be set") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%y_centroid), & + & "Inactive patch " // trim(iStr) // ": y_centroid must not be set") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%z_centroid), & + & "Inactive patch " // trim(iStr) // ": z_centroid must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%length_x), "Inactive patch "//trim(iStr)//": length_x must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%length_y), "Inactive patch "//trim(iStr)//": length_y must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%length_z), "Inactive patch "//trim(iStr)//": length_z must not be set") @@ -336,7 +359,9 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(.not. patch_icpp(patch_id)%alter_patch(0), "Patch "//trim(iStr)//": alter_patch(0) must be true") - @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(patch_id:)), "Patch "//trim(iStr)// ":alter_patch(i) must be false for i >= "//trim(iStr)//". Only preceding patches can be altered") + @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(patch_id:)), & + & "Patch " // trim(iStr) // ":alter_patch(i) must be false for i >= " // trim(iStr) & + & // ". Only preceding patches can be altered") end subroutine s_check_active_patch_alteration_rights !> This subroutine verifies that inactive patches cannot overwrite other patches @@ -347,7 +372,8 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(.not. patch_icpp(patch_id)%alter_patch(0), "Inactive patch "//trim(iStr)//": cannot have alter_patch(0) altered") - @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(1:)), "Inactive patch "//trim(iStr)//": cannot have any alter_patch(i) enabled") + @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(1:)), & + & "Inactive patch " // trim(iStr) // ": cannot have any alter_patch(i) enabled") end subroutine s_check_inactive_patch_alteration_rights !> This subroutine checks the smoothing parameters @@ -357,12 +383,17 @@ contains call s_int_to_str(patch_id, iStr) if (patch_icpp(patch_id)%smoothen) then - @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id >= patch_id, "Smoothen enabled. Patch "//trim(iStr)//": smooth_patch_id must be less than patch_id") - @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id == 0, "Smoothen enabled. Patch "//trim(iStr)//": smooth_patch_id must be greater than zero") - @:PROHIBIT(patch_icpp(patch_id)%smooth_coeff <= 0._wp, "Smoothen enabled. Patch "//trim(iStr)//": smooth_coeff must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id >= patch_id, & + & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_patch_id must be less than patch_id") + @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id == 0, & + & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_patch_id must be greater than zero") + @:PROHIBIT(patch_icpp(patch_id)%smooth_coeff <= 0._wp, & + & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_coeff must be greater than zero") else - @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, "Smoothen disabled. Patch "//trim(iStr)//": smooth_patch_id must be equal to patch_id") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), "Smoothen disabled. Patch "//trim(iStr)//": smooth_coeff must not be set") + @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, & + & "Smoothen disabled. Patch " // trim(iStr) // ": smooth_patch_id must be equal to patch_id") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), & + & "Smoothen disabled. Patch " // trim(iStr) // ": smooth_coeff must not be set") end if end subroutine s_check_supported_patch_smoothing @@ -374,8 +405,10 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(patch_icpp(patch_id)%smoothen, "Inactive patch "//trim(iStr)//": cannot have smoothen enabled") - @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, "Inactive patch "//trim(iStr)//": smooth_patch_id must be equal to patch_id") - @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), "Inactive patch "//trim(iStr)//": smooth_coeff must not be set") + @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, & + & "Inactive patch " // trim(iStr) // ": smooth_patch_id must be equal to patch_id") + @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), & + & "Inactive patch " // trim(iStr) // ": smooth_coeff must not be set") end subroutine s_check_unsupported_patch_smoothing !> This subroutine checks the primitive variables @@ -387,16 +420,24 @@ contains call s_int_to_str(patch_id, iStr) @:PROHIBIT(f_is_default(patch_icpp(patch_id)%vel(1)), "Patch "//trim(iStr)//": vel(1) must be set") - @:PROHIBIT(n == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(2))) .and. (.not. f_approx_equal(patch_icpp(patch_id)%vel(2) , 0._wp)) .and. (.not. mhd), "Patch "//trim(iStr)//": vel(2) must not be set when n = 0") + @:PROHIBIT(n == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(2))) .and. (.not. f_approx_equal(patch_icpp(patch_id) & + & %vel(2), 0._wp)) .and. (.not. mhd), "Patch " // trim(iStr) // ": vel(2) must not be set when n = 0") @:PROHIBIT(n > 0 .and. f_is_default(patch_icpp(patch_id)%vel(2)), "Patch "//trim(iStr)//": vel(2) must be set when n > 0") - @:PROHIBIT(p == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(3))) .and. (.not. f_approx_equal(patch_icpp(patch_id)%vel(3) , 0._wp)) .and. (.not. mhd), "Patch "//trim(iStr)//": vel(3) must not be set when p = 0") + @:PROHIBIT(p == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(3))) .and. (.not. f_approx_equal(patch_icpp(patch_id) & + & %vel(3), 0._wp)) .and. (.not. mhd), "Patch " // trim(iStr) // ": vel(3) must not be set when p = 0") @:PROHIBIT(p > 0 .and. f_is_default(patch_icpp(patch_id)%vel(3)), "Patch "//trim(iStr)//": vel(3) must be set when p > 0") - @:PROHIBIT(mhd .and. (f_is_default(patch_icpp(patch_id)%vel(2)) .or. f_is_default(patch_icpp(patch_id)%vel(3))), "Patch "//trim(iStr)//": All velocities (vel(1:3)) must be set when mhd = true") - @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%rho <= 0._wp, "Patch "//trim(iStr)//": rho must be greater than zero when model_eqns = 1") - @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%gamma <= 0._wp, "Patch "//trim(iStr)//": gamma must be greater than zero when model_eqns = 1") - @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%pi_inf < 0._wp, "Patch "//trim(iStr)//": pi_inf must be greater than or equal to zero when model_eqns = 1") - @:PROHIBIT(patch_icpp(patch_id)%geometry == 5 .and. patch_icpp(patch_id)%pi_inf > 0, "Patch "//trim(iStr)//": pi_inf must be less than or equal to zero when geometry = 5") - @:PROHIBIT(model_eqns == 2 .and. any(patch_icpp(patch_id)%alpha_rho(1:num_fluids) < 0._wp), "Patch "//trim(iStr)//": alpha_rho(1:num_fluids) must be greater than or equal to zero when model_eqns = 2") + @:PROHIBIT(mhd .and. (f_is_default(patch_icpp(patch_id)%vel(2)) .or. f_is_default(patch_icpp(patch_id)%vel(3))), & + & "Patch " // trim(iStr) // ": All velocities (vel(1:3)) must be set when mhd = true") + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%rho <= 0._wp, & + & "Patch " // trim(iStr) // ": rho must be greater than zero when model_eqns = 1") + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%gamma <= 0._wp, & + & "Patch " // trim(iStr) // ": gamma must be greater than zero when model_eqns = 1") + @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%pi_inf < 0._wp, & + & "Patch " // trim(iStr) // ": pi_inf must be greater than or equal to zero when model_eqns = 1") + @:PROHIBIT(patch_icpp(patch_id)%geometry == 5 .and. patch_icpp(patch_id)%pi_inf > 0, & + & "Patch " // trim(iStr) // ": pi_inf must be less than or equal to zero when geometry = 5") + @:PROHIBIT(model_eqns == 2 .and. any(patch_icpp(patch_id)%alpha_rho(1:num_fluids) < 0._wp), & + & "Patch " // trim(iStr) // ": alpha_rho(1:num_fluids) must be greater than or equal to zero when model_eqns = 2") is_set_B(1) = .not. f_is_default(patch_icpp(patch_id)%Bx) is_set_B(2) = .not. f_is_default(patch_icpp(patch_id)%By) @@ -408,9 +449,12 @@ contains @:PROHIBIT(mhd .and. .not. (is_set_B(2) .and. is_set_B(3)), "By and Bz must be set in all MHD simulations") if (model_eqns == 2 .and. num_fluids < num_fluids_max) then - @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho(num_fluids + 1:)), "Patch "//trim(iStr)//": alpha_rho(i) must not be set for i > num_fluids") - @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha(num_fluids + 1:)), "Patch "//trim(iStr)//": alpha(i) must not be set for i > num_fluids") - @:PROHIBIT(f_is_default(patch_icpp(patch_id)%alpha(num_fluids)), "Patch "//trim(iStr)//": alpha(num_fluids) must be set") + @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho(num_fluids + 1:)), & + & "Patch " // trim(iStr) // ": alpha_rho(i) must not be set for i > num_fluids") + @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha(num_fluids + 1:)), & + & "Patch " // trim(iStr) // ": alpha(i) must not be set for i > num_fluids") + @:PROHIBIT(f_is_default(patch_icpp(patch_id)%alpha(num_fluids)), & + & "Patch " // trim(iStr) // ": alpha(num_fluids) must be set") end if if (chemistry) then @@ -426,7 +470,8 @@ contains integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) - @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho), "Inactive patch "//trim(iStr)//": alpha_rho must not be set") + @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho), & + & "Inactive patch " // trim(iStr) // ": alpha_rho must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%rho), "Inactive patch "//trim(iStr)//": rho must not be set") @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%vel), "Inactive patch "//trim(iStr)//": vel must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%pres), "Inactive patch "//trim(iStr)//": pres must not be set") @@ -442,6 +487,8 @@ contains inquire (file=patch_icpp(patch_id)%model_filepath, exist=file_exists) - @:PROHIBIT(.not. file_exists, "Model file "//trim(patch_icpp(patch_id)%model_filepath)// " requested by patch "//trim(iStr)//" does not exist") + @:PROHIBIT(.not. file_exists, & + & "Model file " // trim(patch_icpp(patch_id)%model_filepath) // " requested by patch " // trim(iStr) & + & // " does not exist") end subroutine s_check_model_geometry end module m_check_patches diff --git a/src/pre_process/m_checker.fpp b/src/pre_process/m_checker.fpp index 369dd88eb0..b588dcca1c 100644 --- a/src/pre_process/m_checker.fpp +++ b/src/pre_process/m_checker.fpp @@ -6,9 +6,9 @@ !> @brief Checks pre-process input file parameters for compatibility and correctness module m_checker - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index f0a06843ec..faf22ee2eb 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -4,13 +4,12 @@ !> @brief Writes grid and initial condition data to serial or parallel output files module m_data_output - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code use m_helper - use m_mpi_proxy !< Message passing interface (MPI) module proxy - + use m_mpi_proxy !< Message passing interface (MPI) module proxy #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_compile_specific @@ -43,12 +42,9 @@ module m_data_output end subroutine s_write_abstract_data_files end interface - character(LEN=path_len + 2*name_len), private :: t_step_dir !< - !! Time-step folder into which grid and initial condition data will be placed - - character(LEN=path_len + 2*name_len), public :: restart_dir !< - !! Restart data folder - + !> Time-step folder into which grid and initial condition data will be placed + character(LEN=path_len + 2*name_len), private :: t_step_dir + character(LEN=path_len + 2*name_len), public :: restart_dir !< Restart data folder procedure(s_write_abstract_data_files), pointer :: s_write_data_files => null() contains @@ -64,22 +60,18 @@ contains logical :: file_exist !< checks if file exists character(LEN=15) :: FMT character(LEN=3) :: status - character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< Used to store - !! the number, in character form, of the currently - !! manipulated conservative variable data file - - character(LEN=len_trim(t_step_dir) + name_len) :: file_loc !< - !! Generic string used to store the address of a particular file - - integer :: i, j, k, l, r, c !< Generic loop iterator - integer :: t_step - real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration - real(wp) :: nbub !< Temporary bubble number density - real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params - real(wp) :: rho !< Temporary density - real(wp) :: pres, T !< Temporary pressure - real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions - real(wp) :: pres_mag + !> Used to store the number, in character form, of the currently manipulated conservative variable data file + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num + character(LEN=len_trim(t_step_dir) + name_len) :: file_loc !< Generic string used to store the address of a particular file + integer :: i, j, k, l, r, c !< Generic loop iterator + integer :: t_step + real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration + real(wp) :: nbub !< Temporary bubble number density + real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params + real(wp) :: rho !< Temporary density + real(wp) :: pres, T !< Temporary pressure + real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions + real(wp) :: pres_mag pres_mag = 0._wp @@ -622,7 +614,6 @@ contains logical :: dir_check integer :: i integer :: m_ds, n_ds, p_ds !< down sample dimensions - if (parallel_io .neqv. .true.) then ! Setting the address of the time-step directory write (t_step_dir, '(A,I0,A)') '/p_all/p', proc_rank, '/0' diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index fbc07adda2..28ac47c835 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -27,36 +27,26 @@ module m_global_parameters ! Computational Domain Parameters - integer :: proc_rank !< Rank of the local processor - - !! Number of cells in the x-, y- and z-coordinate directions + integer :: proc_rank !< Rank of the local processor Number of cells in the x-, y- and z-coordinate directions integer :: m integer :: n integer :: p !> @name Max and min number of cells in a direction of each combination of x-,y-, and z- - type(cell_num_bounds) :: cells_bounds - integer(kind=8) :: nGlobal !< Global number of cells in the domain - integer :: m_glb, n_glb, p_glb !< Global number of cells in each direction - integer :: num_dims !< Number of spatial dimensions - integer :: num_vels !< Number of velocity components (different from num_dims for mhd) - logical :: cyl_coord - integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) - real(wp), allocatable, dimension(:) :: x_cc, y_cc, z_cc !< - !! Locations of cell-centers (cc) in x-, y- and z-directions, respectively - - real(wp), allocatable, dimension(:) :: x_cb, y_cb, z_cb !< - !! Locations of cell-boundaries (cb) in x-, y- and z-directions, respectively - - real(wp) :: dx, dy, dz !< - !! Minimum cell-widths in the x-, y- and z-coordinate directions - - type(bounds_info) :: x_domain, y_domain, z_domain !< - !! Locations of the domain bounds in the x-, y- and z-coordinate directions - - logical :: stretch_x, stretch_y, stretch_z !< - !! Grid stretching flags for the x-, y- and z-coordinate directions - + type(cell_num_bounds) :: cells_bounds + integer(kind=8) :: nGlobal !< Global number of cells in the domain + integer :: m_glb, n_glb, p_glb !< Global number of cells in each direction + integer :: num_dims !< Number of spatial dimensions + integer :: num_vels !< Number of velocity components (different from num_dims for mhd) + logical :: cyl_coord + integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) + !> Locations of cell-centers (cc) in x-, y- and z-directions, respectively + real(wp), allocatable, dimension(:) :: x_cc, y_cc, z_cc + !> Locations of cell-boundaries (cb) in x-, y- and z-directions, respectively + real(wp), allocatable, dimension(:) :: x_cb, y_cb, z_cb + real(wp) :: dx, dy, dz !< Minimum cell-widths in the x-, y- and z-coordinate directions + type(bounds_info) :: x_domain, y_domain, z_domain !< Locations of the domain bounds in the x-, y- and z-coordinate directions + logical :: stretch_x, stretch_y, stretch_z !< Grid stretching flags for the x-, y- and z-coordinate directions ! Parameters of the grid stretching function for the x-, y- and z-coordinate ! directions. The "a" parameters are a measure of the rate at which the grid ! is stretched while the remaining parameters are indicative of the location @@ -93,7 +83,6 @@ module m_global_parameters logical :: igr !< Use information geometric regularization integer :: igr_order !< IGR reconstruction order logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling - ! Annotations of the structure, i.e. the organization, of the state vectors type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. @@ -112,7 +101,6 @@ module m_global_parameters type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. integer :: damage_idx !< Index of damage state variable (D) for continuum damage model integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD - ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). ! Stands for "InDices With BUFFer". type(int_bounds_info) :: idwint(1:3) @@ -121,29 +109,24 @@ module m_global_parameters ! this includes the buffer region. idwbuff and idwint are the same otherwise. ! Stands for "InDices With BUFFer". type(int_bounds_info) :: idwbuff(1:3) - type(int_bounds_info) :: bc_x, bc_y, bc_z !< - !! Boundary conditions in the x-, y- and z-coordinate directions - + type(int_bounds_info) :: bc_x, bc_y, bc_z !< Boundary conditions in the x-, y- and z-coordinate directions integer :: shear_num !! Number of shear stress components - integer, dimension(3) :: shear_indices !< - !! Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< - !! Number of shear stress components to reflect for boundary conditions - integer, dimension(3, 2) :: shear_BC_flip_indices !< - !! Indices of shear stress components to reflect for boundary conditions. - !! Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, [indices]) - - logical :: parallel_io !< Format of the data files - logical :: file_per_process !< type of data output - integer :: precision !< Precision of output files - logical :: down_sample !< Down-sample the output data - logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile - real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile - logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow - integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag - real(wp) :: mixlayer_perturb_k0 !< Peak wavenumber of prescribed energy spectra with mixlayer_perturb flag - !! Default value (k0 = 0.4446) is most unstable mode obtained from linear stability analysis - !! See Michalke (1964, JFM) for details + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, + !! [indices]) + integer, dimension(3, 2) :: shear_BC_flip_indices + logical :: parallel_io !< Format of the data files + logical :: file_per_process !< type of data output + integer :: precision !< Precision of output files + logical :: down_sample !< Down-sample the output data + logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile + real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile + logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow + integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag + !> Peak wavenumber of prescribed energy spectra with mixlayer_perturb flag Default value (k0 = 0.4446) is most unstable mode + !! obtained from linear stability analysis See Michalke (1964, JFM) for details + real(wp) :: mixlayer_perturb_k0 logical :: simplex_perturb type(simplex_noise_params) :: simplex_params real(wp) :: pi_fac !< Factor for artificial pi_inf @@ -159,28 +142,21 @@ module m_global_parameters real(wp), dimension(num_fluids_max) :: fluid_rho logical :: elliptic_smoothing integer :: elliptic_smoothing_iters - integer, allocatable, dimension(:) :: proc_coords !< - !! Processor coordinates in MPI_CART_COMM - - integer, allocatable, dimension(:) :: start_idx !< - !! Starting cell-center index of local processor in global grid - + integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM + integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid #ifdef MFC_MPI type(mpi_io_var), public :: MPI_IO_DATA character(LEN=name_len) :: mpiiofs - integer :: mpi_info_int !< - !! MPI info for parallel IO with Lustre file systems + integer :: mpi_info_int !< MPI info for parallel IO with Lustre file systems #endif ! Initial Condition Parameters - integer :: num_patches !< Number of patches composing initial condition - type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp !< - !! Database of the initial condition patch parameters (icpp) for each of the - !! patches employed in the configuration of the initial condition. Note that - !! the maximum allowable number of patches, num_patches_max, may be changed - !! in the module m_derived_types.f90. - + integer :: num_patches !< Number of patches composing initial condition + !> Database of the initial condition patch parameters (icpp) for each of the patches employed in the configuration of the + !! initial condition. Note that the maximum allowable number of patches, num_patches_max, may be changed in the module + !! m_derived_types.f90. + type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp integer :: num_bc_patches !< Number of boundary condition patches logical :: bc_io !< whether or not to save BC data type(bc_patch_parameters), dimension(num_bc_patches_max) :: patch_bc @@ -188,11 +164,9 @@ module m_global_parameters !! employed in the configuration of the boundary conditions ! Fluids Physical Parameters - type(physical_parameters), dimension(num_fluids_max) :: fluid_pp !< - !! Database of the physical parameters of each of the fluids that is present - !! in the flow. These include the stiffened gas equation of state parameters, - !! and the Reynolds numbers. - + !> Database of the physical parameters of each of the fluids that is present in the flow. These include the stiffened gas + !! equation of state parameters, and the Reynolds numbers. + type(physical_parameters), dimension(num_fluids_max) :: fluid_pp ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp real(wp) :: rhoref, pref !< Reference parameters for Tait EOS @@ -259,21 +233,20 @@ module m_global_parameters integer, allocatable, dimension(:,:,:) :: logic_grid type(pres_field) :: pb type(pres_field) :: mv - real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) - integer :: buff_size !< - !! The number of cells that are necessary to be able to store enough boundary - !! conditions data to march the solution in the physical computational domain - !! to the next time-step. - + real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) + !> The number of cells that are necessary to be able to store enough boundary conditions data to march the solution in the + !! physical computational domain to the next time-step. + integer :: buff_size logical :: fft_wrt - logical :: dummy !< AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional is false + !> AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional + !! is false + logical :: dummy contains !> Assigns default values to user inputs prior to reading them in. This allows for an easier consistency check of these !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs integer :: i !< Generic loop operator - ! Logistics case_dir = '.' old_grid = .false. diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index 547226ba6e..c24969c140 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -7,8 +7,7 @@ module m_grid use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code use m_mpi_proxy ! Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers - + use m_helper_basic !< Functions to compare floating point numbers #ifdef MFC_MPI use mpi ! Message passing interface (MPI) module #endif @@ -35,7 +34,6 @@ impure subroutine s_generate_serial_grid ! Generic loop iterator integer :: i, j !< generic loop operators real(wp) :: length !< domain lengths - ! Grid Generation in the x-direction dx = (x_domain%end - x_domain%beg)/real(m + 1, wp) @@ -154,19 +152,13 @@ end subroutine s_generate_serial_grid impure subroutine s_generate_parallel_grid #ifdef MFC_MPI - real(wp) :: length !< domain lengths - + real(wp) :: length !< domain lengths ! Locations of cell boundaries - real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb !< - !! Locations of cell boundaries - - character(LEN=path_len + name_len) :: file_loc !< - !! Generic string used to store the address of a file - + real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb !< Locations of cell boundaries + character(LEN=path_len + name_len) :: file_loc !< Generic string used to store the address of a file integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status - integer :: i, j !< Generic loop integers - + integer :: i, j !< Generic loop integers allocate (x_cb_glb(-1:m_glb)) allocate (y_cb_glb(-1:n_glb)) allocate (z_cb_glb(-1:p_glb)) diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 17d8475a54..6bc2d2c115 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -13,9 +13,9 @@ module m_icpp_patches use m_model ! Subroutine(s) related to STL files use m_derived_types ! Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_global_parameters !< Definitions of the global parameters use m_constants, only: max_2d_fourier_modes, max_sph_harm_degree, small_radius - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper use m_mpi_common use m_assign_variables @@ -29,30 +29,22 @@ module m_icpp_patches real(wp) :: x_centroid, y_centroid, z_centroid real(wp) :: length_x, length_y, length_z integer :: smooth_patch_id - real(wp) :: smooth_coeff !< - !! These variables are analogous in both meaning and use to the similarly - !! named components in the ic_patch_parameters type (see m_derived_types.f90 - !! for additional details). They are employed as a means to more concisely - !! perform the actions necessary to lay out a particular patch on the grid. - - real(wp) :: eta !< - !! In the case that smoothing of patch boundaries is enabled and the boundary - !! between two adjacent patches is to be smeared out, this variable's purpose - !! is to act as a pseudo volume fraction to indicate the contribution of each - !! patch toward the composition of a cell's fluid state. - + !> These variables are analogous in both meaning and use to the similarly named components in the ic_patch_parameters type (see + !! m_derived_types.f90 for additional details). They are employed as a means to more concisely perform the actions necessary to + !! lay out a particular patch on the grid. + real(wp) :: smooth_coeff + !> In the case that smoothing of patch boundaries is enabled and the boundary between two adjacent patches is to be smeared out, + !! this variable's purpose is to act as a pseudo volume fraction to indicate the contribution of each patch toward the + !! composition of a cell's fluid state. + real(wp) :: eta real(wp) :: cart_x, cart_y, cart_z - real(wp) :: sph_phi !< - !! Variables to be used to hold cell locations in Cartesian coordinates if - !! 3D simulation is using cylindrical coordinates - - type(bounds_info) :: x_boundary, y_boundary, z_boundary !< - !! These variables combine the centroid and length parameters associated with - !! a particular patch to yield the locations of the patch boundaries in the - !! x-, y- and z-coordinate directions. They are used as a means to concisely - !! perform the actions necessary to lay out a particular patch on the grid. - - character(len=5) :: istr ! string to store int to string result for error checking + !> Variables to be used to hold cell locations in Cartesian coordinates if 3D simulation is using cylindrical coordinates + real(wp) :: sph_phi + !> These variables combine the centroid and length parameters associated with a particular patch to yield the locations of the + !! patch boundaries in the x-, y- and z-coordinate directions. They are used as a means to concisely perform the actions + !! necessary to lay out a particular patch on the grid. + type(bounds_info) :: x_boundary, y_boundary, z_boundary + character(len=5) :: istr ! string to store int to string result for error checking contains !> @brief Dispatches each initial condition patch to its geometry-specific initialization routine. diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 093d42fdbd..269b457476 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -6,7 +6,7 @@ module m_initial_condition use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_helper use m_variables_conversion ! Subroutines to change the state variables from ! one form to another @@ -27,7 +27,6 @@ module m_initial_condition type(scalar_field), allocatable, dimension(:) :: q_cons_vf !< conservative variables type(scalar_field) :: q_T_sf !< Temperature field type(integer_field), dimension(:,:), allocatable :: bc_type !< bc_type fields - !> @cond #ifdef MFC_MIXED_PRECISION integer(kind=1), allocatable, dimension(:,:,:) :: patch_id_fp @@ -42,7 +41,6 @@ contains !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_initial_condition_module integer :: i, j, k, l !< generic loop iterators - ! Allocating the primitive and conservative variables allocate (q_prim_vf(1:sys_size)) allocate (q_cons_vf(1:sys_size)) @@ -169,7 +167,6 @@ contains !> Deallocation procedures for the module impure subroutine s_finalize_initial_condition_module integer :: i !< Generic loop iterator - ! Dellocating the primitive and conservative variables do i = 1, sys_size deallocate (q_prim_vf(i)%sf) diff --git a/src/pre_process/m_mpi_proxy.fpp b/src/pre_process/m_mpi_proxy.fpp index 22f8156ed3..3d6e1aea6f 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -5,12 +5,12 @@ !> @brief Broadcasts user inputs and decomposes the domain across MPI ranks for pre-processing module m_mpi_proxy #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_helper - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code use m_mpi_common implicit none diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index ff8b59a487..059cd67b4f 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -6,7 +6,7 @@ module m_perturbation use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_boundary_common ! Boundary conditions module use m_helper use m_simplex_noise @@ -55,7 +55,7 @@ contains !> @brief Adds random noise to the velocity and void fraction of the surrounding flow field. impure subroutine s_perturb_surrounding_flow(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< generic loop iterators + integer :: i, j, k !< generic loop iterators real(wp) :: perturb_alpha real(wp) :: rand_real call random_seed() diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 978aefd47e..f745a35552 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -6,27 +6,23 @@ !> @brief Reads and validates user inputs, loads existing grid/IC data, and initializes pre-process modules module m_start_up - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_mpi_common - use m_variables_conversion !< Subroutines to change the state variables from - !! one form to another - - use m_grid !< Procedures to generate (non-)uniform grids - use m_initial_condition !< Procedures to generate initial condition - use m_data_output !< Procedures to write the grid data and the - !! conservative variables to files - - use m_compile_specific !< Compile-specific procedures + use m_variables_conversion !< Subroutines to change the state variables from one form to another + use m_grid !< Procedures to generate (non-)uniform grids + use m_initial_condition !< Procedures to generate initial condition + use m_data_output !< Procedures to write the grid data and the conservative variables to files + use m_compile_specific !< Compile-specific procedures use m_icpp_patches use m_assign_variables - use m_phase_change !< Phase-change module - use m_helper_basic !< Functions to compare floating point numbers + use m_phase_change !< Phase-change module + use m_helper_basic !< Functions to compare floating point numbers use m_helper #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_check_patches @@ -58,13 +54,10 @@ module m_start_up end subroutine s_read_abstract_ic_data_files end interface - character(LEN=path_len + name_len) :: proc_rank_dir !< - !! Location of the folder associated with the rank of the local processor - - character(LEN=path_len + 2*name_len), private :: t_step_dir !< - !! Possible location of time-step folder containing preexisting grid and/or - !! conservative variables data to be used as starting point for pre-process - + character(LEN=path_len + name_len) :: proc_rank_dir !< Location of the folder associated with the rank of the local processor + !> Possible location of time-step folder containing preexisting grid and/or conservative variables data to be used as starting + !! point for pre-process + character(LEN=path_len + 2*name_len), private :: t_step_dir procedure(s_read_abstract_grid_data_files), pointer :: s_read_grid_data_files => null() procedure(s_read_abstract_ic_data_files), pointer :: s_read_ic_data_files => null() contains @@ -72,13 +65,9 @@ contains !> Reads the configuration file pre_process.inp, in order to populate the parameters in module m_global_parameters.f90 with the !! user provided inputs impure subroutine s_read_input_file - character(LEN=name_len) :: file_loc !< - !! Generic string used to store the address of a particular file - - logical :: file_check !< - !! Generic logical used for the purpose of asserting whether a file - !! is or is not present in the designated location - + character(LEN=name_len) :: file_loc !< Generic string used to store the address of a particular file + !> Generic logical used for the purpose of asserting whether a file is or is not present in the designated location + logical :: file_check integer :: iostatus !! Integer to check iostat of file read @@ -136,12 +125,8 @@ contains !> Checking that the user inputs make sense, i.e. that the individual choices are compatible with the code's options and that !! the combination of these choices results into a valid configuration for the pre-process impure subroutine s_check_input_file - character(LEN=len_trim(case_dir)) :: file_loc !< - !! Generic string used to store the address of a particular file - - logical :: dir_check !< - !! Logical variable used to test the existence of folders - + character(LEN=len_trim(case_dir)) :: file_loc !< Generic string used to store the address of a particular file + logical :: dir_check !< Logical variable used to test the existence of folders ! Checking the existence of the case folder case_dir = adjustl(case_dir) @@ -317,19 +302,14 @@ contains !! @param q_cons_vf_in Conservative variables impure subroutine s_read_serial_ic_data_files(q_cons_vf_in) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in - character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc !< + character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc ! Generic string used to store the address of a particular file - character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !< - !! Used to store the variable position, in character form, of the - !! currently manipulated conservative variable file - - logical :: file_check !< - !! Generic logical used for the purpose of asserting whether a file - !! is or is not present in the designated location - + !> Used to store the variable position, in character form, of the currently manipulated conservative variable file + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num + !> Generic logical used for the purpose of asserting whether a file is or is not present in the designated location + logical :: file_check integer :: i, r !< Generic loop iterator - ! Reading the Conservative Variables Data Files do i = 1, sys_size ! Checking whether data file associated with variable position diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index 618488b223..77c6eb59de 100644 --- a/src/pre_process/p_main.f90 +++ b/src/pre_process/p_main.f90 @@ -4,7 +4,7 @@ !> @brief This program takes care of setting up the initial condition and grid data for the multicomponent flow code. program p_main - use m_global_parameters !< Global parameters for the code + use m_global_parameters !< Global parameters for the code use m_start_up implicit none diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 1c2b644ba5..438d21678c 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -6,13 +6,12 @@ !> @brief Applies acoustic pressure source terms including focused, planar, and broadband transducers module m_acoustic_src - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_bubbles !< Bubble dynamic routines + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_bubbles !< Bubble dynamic routines use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers - use m_constants !< Definitions of the constants - + use m_helper_basic !< Functions to compare floating point numbers + use m_constants !< Definitions of the constants implicit none private; public :: s_initialize_acoustic_src, s_precalculate_acoustic_spatial_sources, s_acoustic_src_calculations @@ -59,7 +58,6 @@ contains !> This subroutine initializes the acoustic source module impure subroutine s_initialize_acoustic_src integer :: i, j !< generic loop variables - @:ALLOCATE(loc_acoustic(1:3, 1:num_source), mag(1:num_source), dipole(1:num_source), support(1:num_source), & & length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), & & gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), aperture(1:num_source), & diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index 630ffc017b..67a4dc477c 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -6,8 +6,8 @@ !> @brief Computes gravitational and user-defined body force source terms for the momentum equations module m_body_forces - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion use m_nvtx @@ -57,7 +57,6 @@ contains subroutine s_compute_mixture_density(q_cons_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf integer :: i, j, k, l !< standard iterators - $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n @@ -81,7 +80,6 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf integer :: i, j, k, l !< Loop variables - call s_compute_acceleration(mytime) call s_compute_mixture_density(q_cons_vf) diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index d50e4b926e..998c172496 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -7,12 +7,11 @@ !> @brief Shared bubble-dynamics procedures (radial acceleration, wall pressure, sound speed) for ensemble- and volume-averaged !! models module m_bubbles - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers - + use m_helper_basic !< Functions to compare floating point numbers implicit none real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) @@ -435,8 +434,8 @@ contains real(wp), dimension(5) :: err !< Error estimates for adaptive time stepping real(wp) :: t_new !< Updated time step size real(wp) :: h0, h !< Time step size - real(wp), dimension(4) :: myR_tmp1, myV_tmp1, myR_tmp2, & - & myV_tmp2 !< Bubble radius, radial velocity, and radial acceleration for the inner loop + !> Bubble radius, radial velocity, and radial acceleration for the inner loop + real(wp), dimension(4) :: myR_tmp1, myV_tmp1, myR_tmp2, myV_tmp2 real(wp), dimension(4) :: myPb_tmp1, myMv_tmp1, myPb_tmp2, myMv_tmp2 !< Gas pressure and vapor mass for the inner loop (EL) real(wp) :: fR2, fV2, fpb2, fmass_v2 integer :: iter_count @@ -554,7 +553,6 @@ contains real(wp), dimension(2) :: h_size !< Time step size (h0, h1) real(wp), dimension(3) :: d_norms !< norms (d_0, d_1, d_2) real(wp), dimension(2) :: myR_tmp, myV_tmp, myA_tmp !< Bubble radius, radial velocity, and radial acceleration - ! Determine the starting time step ! Evaluate f(x0,y0) myR_tmp(1) = fR diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index 7a14035a93..4626ac5e9b 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -6,12 +6,11 @@ !> @brief Computes ensemble-averaged (Euler--Euler) bubble source terms for radius, velocity, pressure, and mass transfer module m_bubbles_EE - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_bubbles !< General bubble dynamics procedures - + use m_bubbles !< General bubble dynamics procedures implicit none real(wp), allocatable, dimension(:,:,:) :: bub_adv_src diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 3bf2fa7e18..62433c865f 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -6,14 +6,14 @@ !> @brief Tracks Lagrangian bubbles and couples their dynamics to the Eulerian flow via volume averaging module m_bubbles_EL - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_bubbles_EL_kernels !< Definitions of the kernel functions - use m_bubbles !< General bubble dynamics procedures - use m_variables_conversion !< State variables type conversion procedures + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_bubbles_EL_kernels !< Definitions of the kernel functions + use m_bubbles !< General bubble dynamics procedures + use m_variables_conversion !< State variables type conversion procedures use m_compile_specific use m_boundary_common - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_sim_helpers use m_helper @@ -53,16 +53,14 @@ module m_bubbles_EL real(wp), allocatable, dimension(:,:,:) :: mtn_dveldt !< Time derivative of the bubble's velocity $:GPU_DECLARE(create='[intfc_draddt, intfc_dveldt, gas_dpdt, gas_dmvdt, mtn_dposdt, mtn_dveldt]') - integer, private :: lag_num_ts !< Number of time stages in the time-stepping scheme - + integer, private :: lag_num_ts !< Number of time stages in the time-stepping scheme $:GPU_DECLARE(create='[lag_num_ts]') integer :: nBubs !< Number of bubbles in the local domain real(wp) :: Rmax_glb, Rmin_glb !< Maximum and minimum bubbe size in the local domain !< Projection of the lagrangian particles in the Eulerian framework type(scalar_field), dimension(:), allocatable :: q_beta - integer :: q_beta_idx !< Size of the q_beta vector field - + integer :: q_beta_idx !< Size of the q_beta vector field $:GPU_DECLARE(create='[nBubs, Rmax_glb, Rmin_glb, q_beta, q_beta_idx]') contains @@ -143,8 +141,7 @@ contains integer :: id, bub_id, save_count integer :: i, ios logical :: file_exist, indomain - character(LEN=path_len + 2*name_len) :: path_D_dir !< - + character(LEN=path_len + 2*name_len) :: path_D_dir ! Initialize number of particles bub_id = 0 id = 0 @@ -499,7 +496,7 @@ contains #:endif real(wp), dimension(2) :: Re integer, dimension(3) :: cell - integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached + integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached real(wp) :: dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu !< Dummy variables for unified subgrid bubble subroutines integer :: i, k, l @@ -803,7 +800,6 @@ contains if ((lag_params%cluster_type == 1)) then !< Getting p_cell in terms of only the current cell by interpolation - !< Getting the cell volulme as Omega if (p > 0) then vol = dx(cell(1))*dy(cell(2))*dz(cell(3)) @@ -1532,7 +1528,8 @@ contains subroutine s_calculate_lag_bubble_stats() integer :: k - $:GPU_PARALLEL_LOOP(private='[k]', reduction='[[Rmax_glb], [Rmin_glb]]', reductionOp='[MAX, MIN]', copy='[Rmax_glb, Rmin_glb]') + $:GPU_PARALLEL_LOOP(private='[k]', reduction='[[Rmax_glb], [Rmin_glb]]', reductionOp='[MAX, MIN]', & + & copy='[Rmax_glb, Rmin_glb]') do k = 1, nBubs Rmax_glb = max(Rmax_glb, intfc_rad(k, 1)/bub_R0(k)) Rmin_glb = min(Rmin_glb, intfc_rad(k, 1)/bub_R0(k)) diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index 33cb424583..263b80805b 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -6,8 +6,7 @@ !> @brief Kernel functions (Gaussian, delta) that smear Lagrangian bubble effects onto the Eulerian grid module m_bubbles_EL_kernels - use m_mpi_proxy !< Message passing interface (MPI) module proxy - + use m_mpi_proxy !< Message passing interface (MPI) module proxy implicit none contains diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 70bf11b543..033d9444d1 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -7,8 +7,8 @@ #:include 'macros.fpp' module m_cbc - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion !< State variables type conversion procedures use m_compute_cbc use m_thermochem, only: get_mixture_energy_mass, get_mixture_specific_heat_cv_mass, get_mixture_specific_heat_cp_mass, & @@ -34,9 +34,9 @@ module m_cbc !! Cell-average fluxes (src - source). These are directly determined from the !! cell-average primitive variables, q_prims_rs_vf, and not a Riemann solver. - real(wp), allocatable, dimension(:,:,:,:) :: F_rsx_vf, F_src_rsx_vf !< - real(wp), allocatable, dimension(:,:,:,:) :: F_rsy_vf, F_src_rsy_vf !< - real(wp), allocatable, dimension(:,:,:,:) :: F_rsz_vf, F_src_rsz_vf !< + real(wp), allocatable, dimension(:,:,:,:) :: F_rsx_vf, F_src_rsx_vf + real(wp), allocatable, dimension(:,:,:,:) :: F_rsy_vf, F_src_rsy_vf + real(wp), allocatable, dimension(:,:,:,:) :: F_rsz_vf, F_src_rsz_vf $:GPU_DECLARE(create='[F_rsx_vf, F_src_rsx_vf, F_rsy_vf, F_src_rsy_vf, F_rsz_vf, F_src_rsz_vf]') !! There is a CCE bug that is causing some subset of these variables to interfere @@ -45,29 +45,25 @@ module m_cbc !! in `acc declare create` clauses don't have this problem, so we still need to !! isolate this bug. - real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf_l, flux_src_rsx_vf_l !< + real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf_l, flux_src_rsx_vf_l real(wp), allocatable, dimension(:,:,:,:) :: flux_rsy_vf_l, flux_src_rsy_vf_l real(wp), allocatable, dimension(:,:,:,:) :: flux_rsz_vf_l, flux_src_rsz_vf_l $:GPU_DECLARE(create='[flux_rsx_vf_l, flux_src_rsx_vf_l, flux_rsy_vf_l, flux_src_rsy_vf_l, flux_rsz_vf_l, flux_src_rsz_vf_l]') real(wp), allocatable, dimension(:) :: ds !< Cell-width distribution in the s-direction - ! CBC Coefficients real(wp), allocatable, dimension(:,:) :: fd_coef_x !< Finite diff. coefficients x-dir real(wp), allocatable, dimension(:,:) :: fd_coef_y !< Finite diff. coefficients y-dir - real(wp), allocatable, dimension(:,:) :: fd_coef_z !< Finite diff. coefficients z-dir - - !! The first dimension identifies the location of a coefficient in the FD - !! formula, while the last dimension denotes the location of the CBC. - + !> Finite diff. coefficients z-dir The first dimension identifies the location of a coefficient in the FD formula, while the + !! last dimension denotes the location of the CBC. + real(wp), allocatable, dimension(:,:) :: fd_coef_z ! Bug with NVHPC when using nullified pointers in a declare create ! real(wp), pointer, dimension(:, :) :: fd_coef => null() real(wp), allocatable, dimension(:,:,:) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir real(wp), allocatable, dimension(:,:,:) :: pi_coef_y !< Polynomial interpolant coefficients in y-dir real(wp), allocatable, dimension(:,:,:) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir - $:GPU_DECLARE(create='[ds, fd_coef_x, fd_coef_y, fd_coef_z, pi_coef_x, pi_coef_y, pi_coef_z]') !! The first dimension of the array identifies the polynomial, the @@ -449,7 +445,6 @@ contains subroutine s_associate_cbc_coefficients_pointers(cbc_dir_in, cbc_loc_in) integer, intent(in) :: cbc_dir_in, cbc_loc_in integer :: i !< Generic loop iterator - ! Associating CBC Coefficients in x-direction if (cbc_dir_in == 1) then ! fd_coef => fd_coef_x; if (weno_order > 1) pi_coef => pi_coef_x @@ -556,7 +551,6 @@ contains real(wp) :: Cv, Cp, e_mix, Mw, R_gas real(wp) :: vel_K_sum, vel_dv_dt_sum integer :: i, j, k, r !< Generic loop iterators - ! Reshaping of inputted data and association of the FD and PI ! coefficients, or CBC coefficients, respectively, hinging on ! selected CBC coordinate direction @@ -984,7 +978,6 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: flux_vf, flux_src_vf type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, r !< Generic loop iterators - ! Configuring the coordinate direction indexes and flags ! Determining the indicial shift based on CBC location @@ -1237,7 +1230,6 @@ contains subroutine s_finalize_cbc(flux_vf, flux_src_vf) type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf integer :: i, j, k, r !< Generic loop iterators - ! Determining the indicial shift based on CBC location dj = max(0, cbc_loc) $:GPU_UPDATE(device='[dj]') diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 346228df54..1de553cad6 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -7,11 +7,10 @@ !> @brief Validates simulation input parameters for consistency and supported configurations module m_checker - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_helper - use m_helper_basic !< Functions to compare floating point numbers - + use m_helper_basic !< Functions to compare floating point numbers implicit none private; public :: s_check_inputs @@ -46,21 +45,29 @@ contains !> Checks constraints on WENO scheme parameters impure subroutine s_check_inputs_weno character(len=5) :: numStr !< for int to string conversion - call s_int_to_str(num_stcls_min*weno_order, numStr) - @:PROHIBIT(m + 1 < num_stcls_min*weno_order, "m must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) - @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*weno_order, "For 2D simulation, n must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) - @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*weno_order, "For 3D simulation, p must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is "//trim(numStr)) + @:PROHIBIT(m + 1 < num_stcls_min*weno_order, & + & "m must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " // trim(numStr)) + @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*weno_order, & + & "For 2D simulation, n must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " & + & // trim(numStr)) + @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*weno_order, & + & "For 3D simulation, p must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " & + & // trim(numStr)) end subroutine s_check_inputs_weno !> @brief Validates that the grid resolution is sufficient for the MUSCL reconstruction order. impure subroutine s_check_inputs_muscl character(len=5) :: numStr !< for int to string conversion - call s_int_to_str(num_stcls_min*muscl_order, numStr) - @:PROHIBIT(m + 1 < num_stcls_min*muscl_order, "m must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) - @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*muscl_order, "For 2D simulation, n must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) - @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*muscl_order, "For 3D simulation, p must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is "//trim(numStr)) + @:PROHIBIT(m + 1 < num_stcls_min*muscl_order, & + & "m must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " // trim(numStr)) + @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*muscl_order, & + & "For 2D simulation, n must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " & + & // trim(numStr)) + @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*muscl_order, & + & "For 3D simulation, p must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " & + & // trim(numStr)) end subroutine s_check_inputs_muscl !> Checks constraints on time stepping parameters @@ -72,8 +79,10 @@ contains impure subroutine s_check_inputs_nvidia_uvm #ifdef __NVCOMPILER_GPU_UNIFIED_MEM - @:PROHIBIT(nv_uvm_igr_temps_on_gpu > 3 .or. nv_uvm_igr_temps_on_gpu < 0, "nv_uvm_igr_temps_on_gpu must be in the range [0, 3]") - @:PROHIBIT(nv_uvm_igr_temps_on_gpu == 3 .and. igr_iter_solver == 2, "nv_uvm_igr_temps_on_gpu must be in the range [0, 2] for igr_iter_solver == 2") + @:PROHIBIT(nv_uvm_igr_temps_on_gpu > 3 .or. nv_uvm_igr_temps_on_gpu < 0, & + & "nv_uvm_igr_temps_on_gpu must be in the range [0, 3]") + @:PROHIBIT(nv_uvm_igr_temps_on_gpu == 3 .and. igr_iter_solver == 2, & + & "nv_uvm_igr_temps_on_gpu must be in the range [0, 2] for igr_iter_solver == 2") #endif end subroutine s_check_inputs_nvidia_uvm end module m_checker diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index 279de14b53..f6cab7fa78 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -6,13 +6,12 @@ !> @brief Computes signed-distance level-set fields and surface normals for immersed-boundary patch geometries module m_compute_levelset - use m_ib_patches !< The IB patch parameters - use m_model !< Subroutine(s) related to STL files - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers - + use m_ib_patches !< The IB patch parameters + use m_model !< Subroutine(s) related to STL files + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers implicit none private; public :: s_apply_levelset @@ -77,7 +76,6 @@ contains real(wp), dimension(2) :: center real(wp), dimension(3) :: dist_vec integer :: i, j, ib_patch_id !< Loop index variables - ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -109,7 +107,6 @@ contains real(wp), dimension(1:2) :: center real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation integer :: i, j, k, ib_patch_id !< Loop index variables - ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -189,7 +186,6 @@ contains real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation real(wp) :: length_z integer :: i, j, k, l, ib_patch_id !< Loop index variables - ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -288,7 +284,6 @@ contains integer :: i, j, k !< Loop index variables integer :: idx !< Shortest path direction indicator integer :: ib_patch_id !< patch ID - ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -355,7 +350,6 @@ contains integer :: i, j, k !< Loop index variables integer :: idx !< Shortest path direction indicator integer :: ib_patch_id !< patch ID - ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -404,7 +398,6 @@ contains real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation integer :: i, j, k !< Loop index variables integer :: ib_patch_id !< patch ID - ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -484,7 +477,6 @@ contains real(wp) :: radius, dist real(wp), dimension(3) :: dist_vec, center, periodicity integer :: i, j, k, ib_patch_id !< Loop index variables - ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 86ef8edd1b..90a68aa03c 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -7,13 +7,13 @@ !> @brief Writes solution data, run-time stability diagnostics (ICFL, VCFL, CCFL, Rc), and probe/center-of-mass files module m_data_output - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures use m_compile_specific use m_helper - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_sim_helpers use m_delay_file_access use m_ibm @@ -80,22 +80,16 @@ contains !! information relevant to current simulation. In general, this requires generating a table header for those stability criteria !! which will be written at every time-step. impure subroutine s_open_run_time_information_file - character(LEN=name_len), parameter :: file_name = 'run_time.inf' !< - !! Name of the run-time information file - - character(LEN=path_len + name_len) :: file_path !< - !! Relative path to a file in the case directory - - character(LEN=8) :: file_date !< - !! Creation date of the run-time information file - + character(LEN=name_len), parameter :: file_name = 'run_time.inf' !< Name of the run-time information file + character(LEN=path_len + name_len) :: file_path !< Relative path to a file in the case directory + character(LEN=8) :: file_date !< Creation date of the run-time information file ! Opening the run-time information file file_path = trim(case_dir) // '/' // trim(file_name) open (3, FILE=trim(file_path), form='formatted', STATUS='replace') write (3, '(A)') 'Description: Stability information at ' // 'each time-step of the simulation. This' - write (3, '(13X,A)') 'data is composed of the inviscid ' // 'Courant–Friedrichs–Lewy (ICFL)' + write (3, '(13X,A)') 'data is composed of the inviscid ' // 'Courant–Friedrichs–Lewy (ICFL)' write (3, '(13X,A)') 'number, the viscous CFL (VCFL) number, ' // 'the capillary CFL (CCFL)' write (3, '(13X,A)') 'number and the cell Reynolds (Rc) ' // 'number. Please note that only' write (3, '(13X,A)') 'those stability conditions pertinent ' // 'to the physics included in' @@ -119,10 +113,8 @@ contains !> This opens a formatted data file where the root processor can write out the CoM information impure subroutine s_open_com_files() - character(len=path_len + 3*name_len) :: file_path !< - !! Relative path to the CoM file in the case directory - integer :: i !< Generic loop iterator - + character(len=path_len + 3*name_len) :: file_path !< Relative path to the CoM file in the case directory + integer :: i !< Generic loop iterator do i = 1, num_fluids ! Generating the relative path to the CoM data file write (file_path, '(A,I0,A)') '/fluid', i, '_com.dat' @@ -146,11 +138,9 @@ contains !> This opens a formatted data file where the root processor can write out flow probe information impure subroutine s_open_probe_files - character(LEN=path_len + 3*name_len) :: file_path !< - !! Relative path to the probe data file in the case directory - - integer :: i !< Generic loop iterator - logical :: file_exist + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the probe data file in the case directory + integer :: i !< Generic loop iterator + logical :: file_exist do i = 1, num_probes ! Generating the relative path to the data file @@ -196,7 +186,7 @@ contains impure subroutine s_write_run_time_information(q_prim_vf, t_step) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf integer, intent(in) :: t_step - real(wp) :: rho !< Cell-avg. density + real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction real(wp), dimension(3) :: vel !< Cell-avg. velocity @@ -324,19 +314,12 @@ contains integer, intent(in) :: t_step type(scalar_field), intent(inout), optional :: beta type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type - character(LEN=path_len + 2*name_len) :: t_step_dir !< - !! Relative path to the current time-step directory - - character(LEN=path_len + 3*name_len) :: file_path !< - !! Relative path to the grid and conservative variables data files - - logical :: file_exist !< - !! Logical used to check existence of current time-step directory - - character(LEN=15) :: FMT - integer :: i, j, k, l, r - real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params - + character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the current time-step directory + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files + logical :: file_exist !< Logical used to check existence of current time-step directory + character(LEN=15) :: FMT + integer :: i, j, k, l, r + real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params ! Creating or overwriting the time-step root directory write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all' @@ -718,7 +701,6 @@ contains character(len=10) :: t_step_string integer :: i !< Generic loop iterator integer :: alt_sys !< Altered system size for the lagrangian subgrid bubble model - ! Down sampling variables integer :: m_ds, n_ds, p_ds integer :: m_glb_ds, n_glb_ds, p_glb_ds @@ -1009,7 +991,6 @@ contains real(wp), dimension(num_fluids, 5), intent(in) :: c_mass_in integer :: i !< Generic loop iterator real(wp) :: nondim_time !< Non-dimensional time - ! Non-dimensional time calculation if (t_step_old /= dflt_int) then nondim_time = real(t_step + t_step_old, wp)*dt @@ -1077,13 +1058,11 @@ contains real(wp) :: damage_state integer :: i, j, k, l, s, d !< Generic loop iterator real(wp) :: nondim_time !< Non-dimensional time - real(wp) :: tmp !< - !! Temporary variable to store quantity for mpi_allreduce - - integer :: npts !< Number of included integral points - real(wp) :: rad, thickness !< For integral quantities - logical :: trigger !< For integral quantities - real(wp) :: rhoYks(1:num_species) + real(wp) :: tmp !< Temporary variable to store quantity for mpi_allreduce + integer :: npts !< Number of included integral points + real(wp) :: rad, thickness !< For integral quantities + logical :: trigger !< For integral quantities + real(wp) :: rhoYks(1:num_species) T = dflt_T_guess @@ -1584,7 +1563,6 @@ contains !! and the simulation run-time. impure subroutine s_close_run_time_information_file real(wp) :: run_time !< Run-time of the simulation - ! Writing the footer of and closing the run-time information file write (3, '(A)') ' ' write (3, '(A)') '' @@ -1612,7 +1590,6 @@ contains !> Closes probe files impure subroutine s_close_probe_files integer :: i !< Generic loop iterator - do i = 1, num_probes close (i + 30) end do diff --git a/src/simulation/m_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index 5927a313a9..084a9ebad9 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -7,10 +7,10 @@ #:include 'macros.fpp' module m_derived_variables - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Data output module + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_data_output !< Data output module use m_compile_specific use m_helper use m_finite_differences @@ -103,7 +103,6 @@ contains type(scalar_field), dimension(:), intent(inout) :: q_cons_vf type(vector_field), dimension(:), intent(inout) :: q_prim_ts1, q_prim_ts2 integer :: i, j, k !< Generic loop iterators - if (probe_wrt) then call s_derive_acceleration_component(1, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, x_accel) if (n > 0) then @@ -158,7 +157,6 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf3 real(wp), dimension(0:m, 0:n, 0:p), intent(out) :: q_sf integer :: j, k, l, r !< Generic loop iterators - ! Computing the acceleration component in the x-coordinate direction if (i == 1) then $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) @@ -349,10 +347,9 @@ contains impure subroutine s_derive_center_of_mass(q_vf, c_m) type(scalar_field), dimension(sys_size), intent(in) :: q_vf real(wp), dimension(1:num_fluids, 1:5), intent(inout) :: c_m - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators real(wp) :: tmp, tmp_out !< Temporary variable to store quantity for mpi_allreduce - real(wp) :: dV !< Discrete cell volume - + real(wp) :: dV !< Discrete cell volume c_m(:,:) = 0.0_wp $:GPU_UPDATE(device='[c_m]') diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index a61a032456..2656fc422f 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -8,10 +8,9 @@ module m_fftw use, intrinsic :: iso_c_binding - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy #if defined(MFC_GPU) && defined(__PGI) use cufft #elif defined(MFC_GPU) @@ -31,13 +30,9 @@ module m_fftw type(c_ptr) :: fwd_plan, bwd_plan type(c_ptr) :: fftw_real_data, fftw_cmplx_data, fftw_fltr_cmplx_data integer :: real_size, cmplx_size, x_size, batch_size, Nfq - real(c_double), pointer :: data_real(:) !< Real data - complex(c_double_complex), pointer :: data_cmplx(:) !< - !! Complex data in Fourier space - - complex(c_double_complex), pointer :: data_fltr_cmplx(:) !< - !! Filtered complex data in Fourier space - + real(c_double), pointer :: data_real(:) !< Real data + complex(c_double_complex), pointer :: data_cmplx(:) !< Complex data in Fourier space + complex(c_double_complex), pointer :: data_fltr_cmplx(:) !< Filtered complex data in Fourier space #if defined(MFC_GPU) $:GPU_DECLARE(create='[real_size, cmplx_size, x_size, batch_size, Nfq]') @@ -65,7 +60,6 @@ contains !! the Fourier filter in the azimuthal direction. impure subroutine s_initialize_fftw_module integer :: ierr !< Generic flag used to identify and report GPU errors - ! Size of input array going into DFT real_size = p + 1 ! Size of output array coming out of DFT @@ -125,7 +119,6 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf integer :: i, j, k, l !< Generic loop iterators integer :: ierr !< Generic flag used to identify and report GPU errors - ! Restrict filter to processors that have cells adjacent to axis if (bc_y%beg >= 0) return #if defined(MFC_GPU) diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index aab027d78b..53b957d54a 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -8,12 +8,11 @@ !> @brief Global parameters for the computational domain, fluid properties, and simulation algorithm configuration module m_global_parameters #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_helper_basic !< Functions to compare floating point numbers - + use m_derived_types !< Definitions of the derived types + use m_helper_basic !< Functions to compare floating point numbers ! $:USE_GPU_MODULE() implicit none @@ -26,10 +25,8 @@ module m_global_parameters character(LEN=path_len) :: case_dir !< Case folder location logical :: run_time_info !< Run-time output flag integer :: t_step_old !< Existing IC/grid folder - ! Computational Domain Parameters integer :: proc_rank !< Rank of the local processor - !> @name Number of cells in the x-, y- and z-directions, respectively !> @{ integer :: m, n, p @@ -70,7 +67,6 @@ module m_global_parameters !> @} real(wp) :: dt !< Size of the time-step - $:GPU_DECLARE(create='[x_cb, y_cb, z_cb, x_cc, y_cc, z_cc, dx, dy, dz, dt, m, n, p]') !> @name Starting time-step iteration, stopping time-step iteration and the number of time-step iterations between successive @@ -88,9 +84,8 @@ module m_global_parameters logical :: cfl_adap_dt, cfl_const_dt, cfl_dt integer :: t_step_print !< Number of time-steps between printouts - ! Simulation Algorithm Parameters - integer :: model_eqns !< Multicomponent flow model + integer :: model_eqns !< Multicomponent flow model #:if MFC_CASE_OPTIMIZATION integer, parameter :: num_dims = ${num_dims}$ !< Number of spatial dimensions integer, parameter :: num_vels = ${num_vels}$ !< Number of velocity components (different from num_dims for mhd) @@ -108,8 +103,8 @@ module m_global_parameters integer, parameter :: muscl_polyn = ${muscl_polyn}$ !< Degree of the MUSCL polynomials (polyn) integer, parameter :: weno_order = ${weno_order}$ !< Order of the WENO reconstruction integer, parameter :: muscl_order = ${muscl_order}$ !< Order of the MUSCL order - integer, & - & parameter :: weno_num_stencils = ${weno_num_stencils}$ !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) + !> Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) + integer, parameter :: weno_num_stencils = ${weno_num_stencils}$ integer, parameter :: muscl_lim = ${muscl_lim}$ !< MUSCL Limiter integer, parameter :: num_fluids = ${num_fluids}$ !< number of fluids in the simulation logical, parameter :: wenojs = (${wenojs}$ /= 0) !< WENO-JS (default) @@ -215,7 +210,6 @@ module m_global_parameters integer :: relax_model !< Relaxation model real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model - $:GPU_DECLARE(create='[relax, relax_model, palpha_eps, ptgalpha_eps]') integer :: num_bc_patches @@ -241,12 +235,8 @@ module m_global_parameters logical :: down_sample !< down sample the output files $:GPU_DECLARE(create='[down_sample]') - integer, allocatable, dimension(:) :: proc_coords !< - !! Processor coordinates in MPI_CART_COMM - - integer, allocatable, dimension(:) :: start_idx !< - !! Starting cell-center index of local processor in global grid - + integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM + integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid type(mpi_io_var), public :: MPI_IO_DATA type(mpi_io_ib_var), public :: MPI_IO_IB_DATA type(mpi_io_airfoil_ib_var), public :: MPI_IO_airfoil_IB_DATA @@ -331,44 +321,34 @@ module m_global_parameters $:GPU_DECLARE(create='[dir_idx, dir_flg, dir_idx_tau]') - integer :: buff_size !< - !! The number of cells that are necessary to be able to store enough boundary - !! conditions data to march the solution in the physical computational domain - !! to the next time-step. - + !> The number of cells that are necessary to be able to store enough boundary conditions data to march the solution in the + !! physical computational domain to the next time-step. + integer :: buff_size $:GPU_DECLARE(create='[buff_size]') integer :: shear_num !! Number of shear stress components - integer, dimension(3) :: shear_indices !< - !! Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< - !! Number of shear stress components to reflect for boundary conditions - integer, dimension(3, 2) :: shear_BC_flip_indices !< - !! Indices of shear stress components to reflect for boundary conditions. - !! Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, [indices]) - + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, + !! [indices]) + integer, dimension(3, 2) :: shear_BC_flip_indices $:GPU_DECLARE(create='[shear_num, shear_indices, shear_BC_flip_num, shear_BC_flip_indices]') ! END: Simulation Algorithm Parameters ! Fluids Physical Parameters - type(physical_parameters), dimension(num_fluids_max) :: fluid_pp !< - !! Database of the physical parameters of each of the fluids that is present - !! in the flow. These include the stiffened gas equation of state parameters, - !! and the Reynolds numbers. - + !> Database of the physical parameters of each of the fluids that is present in the flow. These include the stiffened gas + !! equation of state parameters, and the Reynolds numbers. + type(physical_parameters), dimension(num_fluids_max) :: fluid_pp ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp - integer :: fd_order !< - !! The order of the finite-difference (fd) approximations of the first-order - !! derivatives that need to be evaluated when the CoM or flow probe data - !! files are to be written at each time step - - integer :: fd_number !< - !! The finite-difference number is given by MAX(1, fd_order/2). Essentially, - !! it is a measure of the half-size of the finite-difference stencil for the - !! selected order of accuracy. + !> The order of the finite-difference (fd) approximations of the first-order derivatives that need to be evaluated when the CoM + !! or flow probe data files are to be written at each time step + integer :: fd_order + !> The finite-difference number is given by MAX(1, fd_order/2). Essentially, it is a measure of the half-size of the + !! finite-difference stencil for the selected order of accuracy. + integer :: fd_number $:GPU_DECLARE(create='[fd_order, fd_number]') logical :: probe_wrt @@ -405,7 +385,7 @@ module m_global_parameters #:if MFC_CASE_OPTIMIZATION integer, parameter :: nb = ${nb}$ !< Number of eq. bubble sizes #:else - integer :: nb !< Number of eq. bubble sizes + integer :: nb !< Number of eq. bubble sizes #:endif real(wp) :: Eu !< Euler number @@ -525,8 +505,9 @@ module m_global_parameters $:GPU_DECLARE(create='[Bx0]') logical :: fft_wrt - logical :: dummy !< AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional is false - + !> AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional + !! is false + logical :: dummy !> @name Continuum damage model parameters !> @{! real(wp) :: tau_star !< Stress threshold for continuum damage modeling @@ -547,7 +528,6 @@ contains !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs integer :: i, j !< Generic loop iterator - ! Logistics case_dir = '.' run_time_info = .false. diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index 68c83300f5..a526748264 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -7,8 +7,8 @@ !> @brief Computes the left Cauchy--Green deformation tensor and hyperelastic stress source terms module m_hyperelastic - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion !< State variables type conversion procedures use m_finite_differences @@ -18,7 +18,7 @@ module m_hyperelastic !! The btensor at the cell-interior Gaussian quadrature points. !! These tensor is needed to be calculated once and make the code DRY. - type(vector_field) :: btensor !< + type(vector_field) :: btensor $:GPU_DECLARE(create='[btensor]') real(wp), allocatable, dimension(:,:) :: fd_coeff_x_hyper @@ -34,7 +34,6 @@ contains !! obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space impure subroutine s_initialize_hyperelastic_module integer :: i !< generic iterator - @:ALLOCATE(btensor%vf(1:b_size)) do i = 1, b_size @:ALLOCATE(btensor%vf(i)%sf(0:m, 0:n, 0:p)) @@ -95,7 +94,8 @@ contains real(wp) :: G_local integer :: j, k, l, i, r - $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, alpha_K, alpha_rho_K, rho, gamma, pi_inf, qv, G_local, Re, tensora, tensorb]') + $:GPU_PARALLEL_LOOP(collapse=3, & + & private='[i, j, k, l, alpha_K, alpha_rho_K, rho, gamma, pi_inf, qv, G_local, Re, tensora, tensorb]') do l = 0, p do k = 0, n do j = 0, m @@ -214,7 +214,6 @@ contains real(wp) :: trace real(wp), parameter :: f13 = 1._wp/3._wp integer :: i !< Generic loop iterators - ! tensor is the symmetric tensor & calculate the trace of the tensor trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) @@ -252,7 +251,6 @@ contains real(wp) :: trace real(wp), parameter :: f13 = 1._wp/3._wp integer :: i !< Generic loop iterators - ! TODO Make this 1D and 2D capable ! tensor is the symmetric tensor & calculate the trace of the tensor trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) @@ -275,7 +273,6 @@ contains !> @brief Deallocates memory for hyperelastic deformation tensor and finite-difference coefficients. impure subroutine s_finalize_hyperelastic_module() integer :: i !< iterator - ! Deallocating memory do i = 1, b_size @:DEALLOCATE(btensor%vf(i)%sf) diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index 0d23a53e35..535323bfdb 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -6,8 +6,8 @@ !> @brief Computes hypoelastic stress-rate source terms and damage-state evolution module m_hypoelastic - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_finite_differences use m_helper @@ -85,7 +85,6 @@ contains real(wp) :: rho_K, G_K integer :: i, k, l, q, r !< Loop variables integer :: ndirs !< Number of coordinate directions - ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 if (idir == 1) then diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index 179982ca05..c15b3f69ea 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -13,8 +13,8 @@ module m_ib_patches use m_model ! Subroutine(s) related to STL files use m_derived_types ! Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_helper_basic !< Functions to compare floating point numbers + use m_global_parameters !< Definitions of the global parameters + use m_helper_basic !< Functions to compare floating point numbers use m_helper use m_mpi_common @@ -37,7 +37,7 @@ module m_ib_patches !! perform the actions necessary to lay out a particular patch on the grid. real(wp) :: cart_x, cart_y, cart_z - real(wp) :: sph_phi !< + real(wp) :: sph_phi $:GPU_DECLARE(create='[cart_x, cart_y, cart_z, sph_phi]') !! Variables to be used to hold cell locations in Cartesian coordinates if !! 3D simulation is using cylindrical coordinates @@ -324,7 +324,7 @@ contains subroutine s_ib_3D_airfoil(patch_id, ib_markers, xp, yp, zp) integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information real(wp) :: lz, z_max, z_min, f, ca_in, pa, ma, ta, xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c integer :: i, j, k, l, il, ir, jl, jr, ll, lr integer :: Np1, Np2 @@ -518,7 +518,8 @@ contains ! domain and verifying whether the current patch has the permission ! to write to that cell. If both queries check out, the primitive ! variables of the current patch are assigned to this cell. - $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', copyin='[encoded_patch_id, center, length, inverse_rotation, x_cc, y_cc]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', & + & copyin='[encoded_patch_id, center, length, inverse_rotation, x_cc, y_cc]', collapse=2) do j = jl, jr do i = il, ir ! get the x and y coordinates in the local IB frame @@ -545,7 +546,6 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - ! Generic loop iterators integer :: i, j, k integer :: il, ir, jl, jr, kl, kr @@ -857,7 +857,8 @@ contains call get_bounding_indices(bbox_min(1), bbox_max(1), x_cc, il, ir) call get_bounding_indices(bbox_min(2), bbox_max(2), y_cc, jl, jr) - $:GPU_PARALLEL_LOOP(private='[i, j, xy_local, eta]', copyin='[patch_id, encoded_patch_id, center, inverse_rotation, offset, & + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local, eta]', & + & copyin='[patch_id, encoded_patch_id, center, inverse_rotation, offset, & & spc, threshold]', collapse=2) do i = il, ir do j = jl, jr diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index e1f23b628a..bb2a034504 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -7,12 +7,12 @@ !> @brief Ghost-node immersed boundary method: locates ghost/image points, computes interpolation coefficients, and corrects the !! flow state module m_ibm - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures use m_helper - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_constants use m_compute_levelset use m_ib_patches @@ -122,9 +122,9 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Primitive Variables type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive Variables real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), optional, intent(inout) :: pb_in, mv_in - integer :: i, j, k, l, q, r !< Iterator variables - integer :: patch_id !< Patch ID of ghost point - real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables + integer :: i, j, k, l, q, r !< Iterator variables + integer :: patch_id !< Patch ID of ghost point + real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables real(wp), dimension(2) :: Re_K real(wp) :: G_K real(wp) :: qv_K diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index c1aeca4ea9..f989eb76d2 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -7,7 +7,7 @@ !> @brief Iterative ghost rasterization (IGR) for sharp immersed boundary treatment module m_igr - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters use m_variables_conversion use m_mpi_proxy diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index 7c00630aae..c229e9fd6f 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -8,30 +8,26 @@ !> @brief MPI halo exchange, domain decomposition, and buffer packing/unpacking for the simulation solver module m_mpi_proxy #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_mpi_common use m_nvtx use ieee_arithmetic implicit none - integer, private, allocatable, dimension(:) :: ib_buff_send !< - !! This variable is utilized to pack and send the buffer of the immersed - !! boundary markers, for a single computational domain boundary at the - !! time, to the relevant neighboring processor. - - integer, private, allocatable, dimension(:) :: ib_buff_recv !< - !! q_cons_buff_recv is utilized to receive and unpack the buffer of the - !! immersed boundary markers, for a single computational domain boundary - !! at the time, from the relevant neighboring processor. - - integer :: i_halo_size + !> This variable is utilized to pack and send the buffer of the immersed boundary markers, for a single computational domain + !! boundary at the time, to the relevant neighboring processor. + integer, private, allocatable, dimension(:) :: ib_buff_send + !> q_cons_buff_recv is utilized to receive and unpack the buffer of the immersed boundary markers, for a single computational + !! domain boundary at the time, from the relevant neighboring processor. + integer, private, allocatable, dimension(:) :: ib_buff_recv + integer :: i_halo_size $:GPU_DECLARE(create='[i_halo_size]') contains @@ -64,7 +60,6 @@ contains integer :: i, j !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors - call MPI_BCAST(case_dir, len(case_dir), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) #:for VAR in ['k_x', 'k_y', 'k_z', 'w_x', 'w_y', 'w_z', 'p_x', 'p_y', & @@ -184,7 +179,8 @@ contains end if do i = 1, num_fluids_max - #:for VAR in ['bc_x%alpha_rho_in','bc_x%alpha_in','bc_y%alpha_rho_in','bc_y%alpha_in','bc_z%alpha_rho_in','bc_z%alpha_in'] + #:for VAR in ['bc_x%alpha_rho_in','bc_x%alpha_in','bc_y%alpha_rho_in','bc_y%alpha_in','bc_z%alpha_rho_in', & + & 'bc_z%alpha_in'] call MPI_BCAST(${VAR}$ (i), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor end do diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index 3f8173104a..735b14afd7 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -6,10 +6,9 @@ !> @brief MUSCL reconstruction with interface sharpening for contact-preserving advection module m_muscl - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion !< State variables type conversion procedures - #ifdef MFC_OpenACC use openacc #endif @@ -55,7 +54,8 @@ contains is3_muscl%end = p - is3_muscl%beg - @:ALLOCATE(v_rs_ws_x_muscl(is1_muscl%beg:is1_muscl%end, is2_muscl%beg:is2_muscl%end, is3_muscl%beg:is3_muscl%end, 1:sys_size)) + @:ALLOCATE(v_rs_ws_x_muscl(is1_muscl%beg:is1_muscl%end, is2_muscl%beg:is2_muscl%end, is3_muscl%beg:is3_muscl%end, & + & 1:sys_size)) if (n == 0) return @@ -71,7 +71,8 @@ contains is3_muscl%end = p - is3_muscl%beg - @:ALLOCATE(v_rs_ws_y_muscl(is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, is3_muscl%beg:is3_muscl%end, 1:sys_size)) + @:ALLOCATE(v_rs_ws_y_muscl(is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, is3_muscl%beg:is3_muscl%end, & + & 1:sys_size)) if (p == 0) return @@ -80,7 +81,8 @@ contains is1_muscl%beg = -buff_size; is1_muscl%end = m - is1_muscl%beg is3_muscl%beg = -buff_size; is3_muscl%end = p - is3_muscl%beg - @:ALLOCATE(v_rs_ws_z_muscl(is3_muscl%beg:is3_muscl%end, is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, 1:sys_size)) + @:ALLOCATE(v_rs_ws_z_muscl(is3_muscl%beg:is3_muscl%end, is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, & + & 1:sys_size)) end subroutine s_initialize_muscl_module !> @brief Performs MUSCL reconstruction of left and right cell-boundary values from cell-averaged variables. @@ -280,7 +282,6 @@ contains type(scalar_field), dimension(:), intent(in) :: v_vf integer, intent(in) :: muscl_dir integer :: j, k, l, q !< Generic loop iterators - ! Determining the number of cell-average variables which will be ! muscl-reconstructed and mapping their indical bounds in the x-, ! y- and z-directions to those in the s1-, s2- and s3-directions diff --git a/src/simulation/m_pressure_relaxation.fpp b/src/simulation/m_pressure_relaxation.fpp index 8471352bb7..8c68973b60 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -8,9 +8,8 @@ !> @brief Pressure relaxation for the six-equation multi-component model via Newton--Raphson equilibration and volume-fraction !! correction module m_pressure_relaxation - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters implicit none private; public :: s_pressure_relaxation_procedure, s_initialize_pressure_relaxation_module, & diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index d47298296e..09bb409158 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -7,11 +7,11 @@ !> @brief Quadrature-based moment methods (QBMM) for polydisperse bubble moment inversion and transport module m_qbmm - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 9da3a37342..dd57feff6b 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -8,21 +8,17 @@ !> @brief Assembles the right-hand side of the governing equations using finite-volume flux differencing, Riemann solvers, and !! physical source terms module m_rhs - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_weno !< Weighted and essentially non-oscillatory (WENO) - !! schemes for spatial reconstruction of variables - - use m_muscl !< Monotonic Upstream-centered (MUSCL) - !! schemes for conservation laws - - use m_riemann_solvers !< Exact and approximate Riemann problem solvers - use m_cbc !< Characteristic boundary conditions (CBC) - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines + use m_weno !< Weighted and essentially non-oscillatory (WENO) schemes for spatial reconstruction of variables + use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws + use m_riemann_solvers !< Exact and approximate Riemann problem solvers + use m_cbc !< Characteristic boundary conditions (CBC) + use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines use m_bubbles_EL - use m_qbmm !< Moment inversion + use m_qbmm !< Moment inversion use m_hypoelastic use m_hyperelastic use m_acoustic_src @@ -44,13 +40,13 @@ module m_rhs !! This variable contains the WENO-reconstructed values of the cell-average !! conservative variables, which are located in q_cons_vf, at cell-interior !! Gaussian quadrature points (QP). - type(vector_field) :: q_cons_qp !< + type(vector_field) :: q_cons_qp $:GPU_DECLARE(create='[q_cons_qp]') !! The primitive variables at cell-interior Gaussian quadrature points. These !! are calculated from the conservative variables and gradient magnitude (GM) !! of the volume fractions, q_cons_qp and gm_alpha_qp, respectively. - type(vector_field) :: q_prim_qp !< + type(vector_field) :: q_prim_qp $:GPU_DECLARE(create='[q_prim_qp]') !> @name The first-order spatial derivatives of the primitive variables at cell- interior Gaussian quadrature points. These are @@ -76,11 +72,9 @@ module m_rhs type(scalar_field), allocatable, dimension(:) :: tau_Re_vf $:GPU_DECLARE(create='[tau_Re_vf]') - type(vector_field) :: gm_alpha_qp !< - !! The gradient magnitude of the volume fractions at cell-interior Gaussian - !! quadrature points. gm_alpha_qp is calculated from individual first-order - !! spatial derivatives located in dq_prim_ds_qp. - + !> The gradient magnitude of the volume fractions at cell-interior Gaussian quadrature points. gm_alpha_qp is calculated from + !! individual first-order spatial derivatives located in dq_prim_ds_qp. + type(vector_field) :: gm_alpha_qp $:GPU_DECLARE(create='[gm_alpha_qp]') !> @name The left and right WENO-reconstructed cell-boundary values of the cell- average gradient magnitude of volume fractions, @@ -144,7 +138,6 @@ contains !! procedures that are necessary to setup the module. impure subroutine s_initialize_rhs_module integer :: i, j, k, l, id !< Generic loop iterators - $:GPU_ENTER_DATA(copyin='[idwbuff]') $:GPU_UPDATE(device='[idwbuff]') @@ -153,10 +146,12 @@ contains if (.not. igr) then do l = 1, sys_size - @:ALLOCATE(q_cons_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_cons_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do do l = mom_idx%beg, E_idx - @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -165,11 +160,13 @@ contains ! the last equation. If this changes then this logic will ! need updated do l = adv_idx%end + 1, sys_size - 1 - @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do else do l = adv_idx%end + 1, sys_size - @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -179,7 +176,8 @@ contains do l = 1, cont_idx%end if (relativity) then ! Cons and Prim densities are different for relativity - @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) else q_prim_qp%vf(l)%sf => q_cons_qp%vf(l)%sf $:GPU_ENTER_DATA(copyin='[q_prim_qp%vf(l)%sf]') @@ -219,35 +217,43 @@ contains if (i == 1) then do l = 1, sys_size - @:ALLOCATE(flux_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do if (viscous .or. surface_tension) then do l = mom_idx%beg, E_idx - @:ALLOCATE(flux_src_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if - @:ALLOCATE(flux_src_n(i)%vf(adv_idx%beg)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(adv_idx%beg)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) if (riemann_solver == 1 .or. riemann_solver == 4) then do l = adv_idx%beg + 1, adv_idx%end - @:ALLOCATE(flux_src_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if if (chemistry) then do l = chemxb, chemxe - @:ALLOCATE(flux_src_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do if (chem_params%diffusion .and. .not. viscous) then - @:ALLOCATE(flux_src_n(i)%vf(E_idx)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_src_n(i)%vf(E_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end if end if else do l = 1, sys_size - @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -294,29 +300,41 @@ contains @:ALLOCATE(qL_prim(i)%vf(1:sys_size)) @:ALLOCATE(qR_prim(i)%vf(1:sys_size)) do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(qL_prim(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(qR_prim(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(qL_prim(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(qR_prim(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(qL_prim(i), qR_prim(i)) end do - @:ALLOCATE(qL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - @:ALLOCATE(qR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:sys_size)) + @:ALLOCATE(qR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:sys_size)) if (n > 0) then - @:ALLOCATE(qL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - @:ALLOCATE(qR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:sys_size)) + @:ALLOCATE(qR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:sys_size)) else - @:ALLOCATE(qL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - @:ALLOCATE(qR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:sys_size)) + @:ALLOCATE(qR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:sys_size)) end if if (p > 0) then - @:ALLOCATE(qL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, 1:sys_size)) - @:ALLOCATE(qR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, 1:sys_size)) + @:ALLOCATE(qL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & + & 1:sys_size)) + @:ALLOCATE(qR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & + & 1:sys_size)) else - @:ALLOCATE(qL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) - @:ALLOCATE(qR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + @:ALLOCATE(qL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:sys_size)) + @:ALLOCATE(qR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:sys_size)) end if if (.not. viscous) then @@ -344,10 +362,12 @@ contains if (viscous) then @:ALLOCATE(tau_Re_vf(1:sys_size)) do i = 1, num_dims - @:ALLOCATE(tau_Re_vf(cont_idx%end + i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(tau_Re_vf(cont_idx%end + i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(tau_Re_vf(cont_idx%end + i)) end do - @:ALLOCATE(tau_Re_vf(E_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(tau_Re_vf(E_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(tau_Re_vf(E_idx)) @:ALLOCATE(dq_prim_dx_qp(1)%vf(1:sys_size)) @@ -355,21 +375,24 @@ contains @:ALLOCATE(dq_prim_dz_qp(1)%vf(1:sys_size)) do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dq_prim_dx_qp(1)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dq_prim_dx_qp(1)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dx_qp(1)) if (n > 0) then do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dq_prim_dy_qp(1)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dq_prim_dy_qp(1)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dy_qp(1)) if (p > 0) then do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dq_prim_dz_qp(1)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dq_prim_dz_qp(1)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dz_qp(1)) end if @@ -386,21 +409,27 @@ contains do i = 1, num_dims do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dqL_prim_dx_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(dqR_prim_dx_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqL_prim_dx_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqR_prim_dx_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do if (n > 0) then do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dqL_prim_dy_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(dqR_prim_dy_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqL_prim_dy_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqR_prim_dy_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if if (p > 0) then do l = mom_idx%beg, mom_idx%end - @:ALLOCATE(dqL_prim_dz_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) - @:ALLOCATE(dqR_prim_dz_n(i)%vf(l)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqL_prim_dz_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(dqR_prim_dz_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -409,23 +438,33 @@ contains end do if (weno_Re_flux) then - @:ALLOCATE(dqL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) if (n > 0) then - @:ALLOCATE(dqL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) else - @:ALLOCATE(dqL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) end if if (p > 0) then - @:ALLOCATE(dqL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) else - @:ALLOCATE(dqL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) - @:ALLOCATE(dqR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + @:ALLOCATE(dqR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) end if end if ! end allocation for weno_Re_flux else @@ -468,14 +507,16 @@ contains do i = 0, 2 do j = 0, 2 do k = 1, nb - @:ALLOCATE(mom_3d(i, j, k)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(mom_3d(i, j, k)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(mom_3d(i, j, k)) end do end do end do do i = 1, nmomsp - @:ALLOCATE(mom_sp(i)%sf( idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(mom_sp(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(mom_sp(i)) end do end if @@ -492,7 +533,8 @@ contains end if if (alt_soundspeed) then - @:ALLOCATE(blkmod1(0:m, 0:n, 0:p), blkmod2(0:m, 0:n, 0:p), alpha1(0:m, 0:n, 0:p), alpha2(0:m, 0:n, 0:p), Kterm(0:m, 0:n, 0:p)) + @:ALLOCATE(blkmod1(0:m, 0:n, 0:p), blkmod2(0:m, 0:n, 0:p), alpha1(0:m, 0:n, 0:p), alpha2(0:m, 0:n, 0:p), Kterm(0:m, & + & 0:n, 0:p)) end if call s_initialize_pressure_relaxation_module @@ -523,7 +565,6 @@ contains real(wp) :: t_start, t_finish integer :: id integer(kind=8) :: i, j, k, l, q !< Generic loop iterators - call nvtxStartRange("COMPUTE-RHS") call cpu_time(t_start) @@ -984,7 +1025,8 @@ contains $:END_GPU_PARALLEL_LOOP() if (model_eqns == 3) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop, k, l, q, inv_ds, advected_qty_val, pressure_val, flux_face1, flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4, private='[i_fluid_loop, k, l, q, inv_ds, advected_qty_val, pressure_val, & + & flux_face1, flux_face2]') do l = 0, p do k = 0, n do q = 0, m @@ -1079,7 +1121,8 @@ contains end if if (model_eqns == 3) then - $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop, k, l, q, inv_ds, advected_qty_val, pressure_val, flux_face1, flux_face2]') + $:GPU_PARALLEL_LOOP(collapse=4, private='[i_fluid_loop, k, l, q, inv_ds, advected_qty_val, pressure_val, & + & flux_face1, flux_face2]') do k = 0, p do q = 0, n do l = 0, m diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 473b5b1dd9..46809ff412 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -9,14 +9,14 @@ #:include 'inline_riemann.fpp' module m_riemann_solvers - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_bubbles !< To get the bubble wall pressure function + use m_bubbles !< To get the bubble wall pressure function use m_bubbles_EE - use m_surface_tension !< To get the capillary fluxes - use m_helper_basic !< Functions to compare floating point numbers + use m_surface_tension !< To get the capillary fluxes + use m_helper_basic !< Functions to compare floating point numbers 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 @@ -45,9 +45,9 @@ module m_riemann_solvers !! the left and right states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. !> @{ - real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsx_vf !< - real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsy_vf !< - real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsz_vf !< + real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsx_vf + real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsy_vf + real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsz_vf $:GPU_DECLARE(create='[flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf]') !> @} @@ -226,7 +226,6 @@ contains type(riemann_states_vec3) :: b4 ! 4-magnetic field components (spatial: b4x, b4y, b4z) type(riemann_states_vec3) :: cm ! Conservative momentum variables integer :: i, j, k, l, q !< Generic loop iterators - ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -869,16 +868,16 @@ contains 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)`. + 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 - real(wp), dimension(num_dims, num_dims) :: vel_grad_L, & - & vel_grad_R !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + 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 @@ -920,7 +919,6 @@ contains 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, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -1813,7 +1811,6 @@ contains 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 @@ -2453,7 +2450,8 @@ contains end do $:END_GPU_PARALLEL_LOOP() else if (model_eqns == 2 .and. bubbles_euler) then - $: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, & + $: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, & @@ -3682,7 +3680,6 @@ contains 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/) @@ -4364,10 +4361,9 @@ contains 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, 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. @@ -4379,7 +4375,6 @@ contains 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. - $: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]') do l_loop = isz%beg, isz%end @@ -4489,7 +4484,6 @@ contains ! 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 @@ -4520,7 +4514,6 @@ contains ! Local variables integer :: i_dim !< Loop iterator for diagonal components. - tau_bulk_out = 0.0_wp do i_dim = 1, num_dims @@ -4537,7 +4530,6 @@ contains 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) diff --git a/src/simulation/m_sim_helpers.fpp b/src/simulation/m_sim_helpers.fpp index 08731acd14..655dee9f29 100644 --- a/src/simulation/m_sim_helpers.fpp +++ b/src/simulation/m_sim_helpers.fpp @@ -7,7 +7,7 @@ !> @brief Simulation helper routines for enthalpy computation, CFL calculation, and stability checks module m_sim_helpers - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters use m_variables_conversion diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 8acc84f817..404c5ca971 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -7,36 +7,31 @@ !> @brief Reads input files, loads initial conditions and grid data, and orchestrates solver initialization and finalization module m_start_up - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_mpi_common use m_variables_conversion !< State variables type conversion procedures - use m_weno !< Weighted and essentially non-oscillatory (WENO) - !! schemes for spatial reconstruction of variables - - use m_muscl !< Monotonic Upstream-centered (MUSCL) - !! schemes for convservation laws - - use m_riemann_solvers !< Exact and approximate Riemann problem solvers - use m_cbc !< Characteristic boundary conditions (CBC) + use m_weno !< Weighted and essentially non-oscillatory (WENO) schemes for spatial reconstruction of variables + use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for convservation laws + use m_riemann_solvers !< Exact and approximate Riemann problem solvers + use m_cbc !< Characteristic boundary conditions (CBC) use m_boundary_common - use m_acoustic_src !< Acoustic source calculations - use m_rhs !< Right-hand-side (RHS) evaluation procedures - use m_chemistry !< Chemistry module - use m_data_output !< Run-time info & solution data output procedures - use m_time_steppers !< Time-stepping algorithms - use m_qbmm !< Quadrature MOM - use m_derived_variables !< Procedures used to compute quantities derived - !! from the conservative and primitive variables + use m_acoustic_src !< Acoustic source calculations + use m_rhs !< Right-hand-side (RHS) evaluation procedures + use m_chemistry !< Chemistry module + use m_data_output !< Run-time info & solution data output procedures + use m_time_steppers !< Time-stepping algorithms + use m_qbmm !< Quadrature MOM + use m_derived_variables !< Procedures used to compute quantities derived from the conservative and primitive variables use m_hypoelastic use m_hyperelastic - use m_phase_change !< Phase-change module + use m_phase_change !< Phase-change module use m_viscous - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL !< Lagrange bubble dynamics routines + use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines + use m_bubbles_EL !< Lagrange bubble dynamics routines use ieee_arithmetic - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper $:USE_GPU_MODULE() @@ -78,10 +73,8 @@ contains impure subroutine s_read_input_file ! Relative path to the input file provided by the user character(LEN=name_len), parameter :: file_path = './simulation.inp' - logical :: file_exist !< - !! Logical used to check the existence of the input file - - integer :: iostatus + logical :: file_exist !< Logical used to check the existence of the input file + integer :: iostatus !! Integer to check iostat of file read character(len=1000) :: line @@ -182,17 +175,12 @@ contains !! @param q_cons_vf Cell-averaged conservative variables impure subroutine s_read_serial_data_files(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - character(LEN=path_len + 2*name_len) :: t_step_dir !< - !! Relative path to the starting time-step directory - - character(LEN=path_len + 3*name_len) :: file_path !< - !! Relative path to the grid and conservative variables data files - - logical :: file_exist !< + character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the starting time-step directory + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files + logical :: file_exist ! Logical used to check the existence of the data files integer :: i, r !< Generic loop iterator - ! Confirming that the directory from which the initial condition and ! the grid data files are to be read in exists and exiting otherwise if (cfl_dt) then @@ -875,8 +863,12 @@ contains call s_initialize_global_parameters_module() #:if USING_AMD #: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. adv_idx%end > 20 .and. (.not. chemistry), "CBC module with AMD compiler requires adv_idx%end <= 20 when case optimization is turned off") - @:PROHIBIT(any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == ${BC}$) .and. sys_size > 20 .and. (chemistry), "CBC module with AMD compiler and chemistry requires sys_size <= 20 when case optimization is turned off") + @:PROHIBIT(any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, & + & bc_z%end/) == ${BC}$) .and. adv_idx%end > 20 .and. (.not. chemistry), & + & "CBC module with AMD compiler requires adv_idx%end <= 20 when case optimization is turned off") + @:PROHIBIT(any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, & + & bc_z%end/) == ${BC}$) .and. sys_size > 20 .and. (chemistry), & + & "CBC module with AMD compiler and chemistry requires sys_size <= 20 when case optimization is turned off") #:endfor #:endif if (bubbles_euler .or. bubbles_lagrange) then diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index fca258e86a..88fc6d6fc6 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -8,14 +8,12 @@ !> @brief Computes capillary source fluxes and color-function gradients for the diffuse-interface surface tension model module m_surface_tension - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion use m_weno - use m_muscl !< Monotonic Upstream-centered (MUSCL) - !! schemes for conservation laws - + use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws use m_helper use m_boundary_common @@ -57,8 +55,10 @@ contains @:ALLOCATE(gR_y(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, num_dims + 1)) if (p > 0) then - @:ALLOCATE(gL_z(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, num_dims + 1)) - @:ALLOCATE(gR_z(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, num_dims + 1)) + @:ALLOCATE(gL_z(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & + & num_dims + 1)) + @:ALLOCATE(gR_z(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & + & num_dims + 1)) end if end subroutine s_initialize_surface_tension_module diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 41e09a94f9..137f9d5c00 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -7,16 +7,16 @@ !> @brief Total-variation-diminishing (TVD) Runge--Kutta time integrators (1st-, 2nd-, and 3rd-order SSP) module m_time_steppers - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_rhs !< Right-hane-side (RHS) evaluation procedures - use m_pressure_relaxation !< Pressure relaxation procedures - use m_data_output !< Run-time info & solution data output procedures - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL !< Lagrange bubble dynamics routines + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_rhs !< Right-hane-side (RHS) evaluation procedures + use m_pressure_relaxation !< Pressure relaxation procedures + use m_data_output !< Run-time info & solution data output procedures + use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines + use m_bubbles_EL !< Lagrange bubble dynamics routines use m_ibm use m_hyperelastic - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_boundary_common use m_helper use m_sim_helpers @@ -28,33 +28,20 @@ module m_time_steppers implicit none - type(vector_field), allocatable, dimension(:) :: q_cons_ts !< - !! Cell-average conservative variables at each time-stage (TS) - - type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< - !! Cell-average primitive variables at the current time-stage - - type(scalar_field), allocatable, dimension(:) :: rhs_vf !< - !! Cell-average RHS variables at the current time-stage - - type(integer_field), allocatable, dimension(:,:) :: bc_type !< - !! Boundary condition identifiers - - type(vector_field), allocatable, dimension(:) :: q_prim_ts1, q_prim_ts2 !< - !! Cell-average primitive variables at consecutive TIMESTEPS - - real(wp), allocatable, dimension(:,:,:,:,:) :: rhs_pb - type(scalar_field) :: q_T_sf !< - !! Cell-average temperature variables at the current time-stage - - real(wp), allocatable, dimension(:,:,:,:,:) :: rhs_mv - real(wp), allocatable, dimension(:,:,:) :: max_dt - integer, private :: num_ts !< - !! Number of time stages in the time-stepping scheme - - integer :: stor !< storage index - real(wp), allocatable, dimension(:,:) :: rk_coef - integer, private :: num_probe_ts + type(vector_field), allocatable, dimension(:) :: q_cons_ts !< Cell-average conservative variables at each time-stage (TS) + type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< Cell-average primitive variables at the current time-stage + type(scalar_field), allocatable, dimension(:) :: rhs_vf !< Cell-average RHS variables at the current time-stage + type(integer_field), allocatable, dimension(:,:) :: bc_type !< Boundary condition identifiers + !> Cell-average primitive variables at consecutive TIMESTEPS + type(vector_field), allocatable, dimension(:) :: q_prim_ts1, q_prim_ts2 + real(wp), allocatable, dimension(:,:,:,:,:) :: rhs_pb + type(scalar_field) :: q_T_sf !< Cell-average temperature variables at the current time-stage + real(wp), allocatable, dimension(:,:,:,:,:) :: rhs_mv + real(wp), allocatable, dimension(:,:,:) :: max_dt + integer, private :: num_ts !< Number of time stages in the time-stepping scheme + integer :: stor !< storage index + real(wp), allocatable, dimension(:,:) :: rk_coef + integer, private :: num_probe_ts $:GPU_DECLARE(create='[q_cons_ts, q_prim_vf, q_T_sf, rhs_vf, q_prim_ts1, q_prim_ts2, rhs_mv, rhs_pb, max_dt, rk_coef, stor, bc_type]') @@ -82,7 +69,6 @@ contains #endif #endif integer :: i, j !< Generic loop iterators - ! Setting number of time-stages for selected time-stepping scheme if (time_stepper == 1) then num_ts = 1 @@ -113,7 +99,8 @@ contains do j = 1, sys_size ! q_cons_ts(1) lives on the device - @:ALLOCATE(q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(q_cons_ts(1)%vf(j)%sf) if (num_ts == 2) then if (nv_uvm_out_of_core) then @@ -121,7 +108,8 @@ contains q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) else - @:ALLOCATE(q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(q_cons_ts(2)%vf(j)%sf) end if end if @@ -189,7 +177,8 @@ contains !> @endcond do i = 1, num_ts do j = 1, sys_size - @:ALLOCATE(q_cons_ts(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_cons_ts(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_cons_ts(i)) end do @@ -207,7 +196,8 @@ contains do i = 1, num_probe_ts do j = 1, sys_size - @:ALLOCATE(q_prim_ts1(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_ts1(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_prim_ts1(i)) end do @@ -220,7 +210,8 @@ contains do i = 1, num_probe_ts do j = 1, sys_size - @:ALLOCATE(q_prim_ts2(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_ts2(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_prim_ts2(i)) end do @@ -231,67 +222,78 @@ contains if (.not. igr) then do i = 1, adv_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do if (bubbles_euler) then do i = bub_idx%beg, bub_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do if (adv_n) then - @:ALLOCATE(q_prim_vf(n_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(n_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(n_idx)) end if end if if (mhd) then do i = B_idx%beg, B_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (elasticity) then do i = stress_idx%beg, stress_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (hyperelasticity) then do i = xibeg, xiend + 1 - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (cont_damage) then - @:ALLOCATE(q_prim_vf(damage_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(damage_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(damage_idx)) end if if (hyper_cleaning) then - @:ALLOCATE(q_prim_vf(psi_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(psi_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(psi_idx)) end if if (model_eqns == 3) then do i = internalEnergies_idx%beg, internalEnergies_idx%end - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (surface_tension) then - @:ALLOCATE(q_prim_vf(c_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(c_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(c_idx)) end if if (chemistry) then do i = chemxb, chemxe - @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do @@ -303,21 +305,27 @@ contains @:ALLOCATE(pb_ts(1:2)) ! Initialize bubble variables pb and mv at all quadrature nodes for all R0 bins if (qbmm .and. (.not. polytropic)) then - @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(1)) - @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(2)) - @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:nnode, 1:nb)) else if (qbmm .and. polytropic) then - @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(1)) - @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(2)) - @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) else @:ALLOCATE(pb_ts(1)%sf(0,0,0,0,0)) @:ACC_SETUP_SFs(pb_ts(1)) @@ -331,21 +339,27 @@ contains @:ALLOCATE(mv_ts(1:2)) if (qbmm .and. (.not. polytropic)) then - @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(1)) - @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(2)) - @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, 1:nnode, 1:nb)) + @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & + & 1:nnode, 1:nb)) else if (qbmm .and. polytropic) then - @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(1)) - @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(2)) - @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) else @:ALLOCATE(mv_ts(1)%sf(0,0,0,0,0)) @:ACC_SETUP_SFs(mv_ts(1)) @@ -603,7 +617,7 @@ contains !> @brief Computes the global time step size from CFL stability constraints across all cells. impure subroutine s_compute_dt() - real(wp) :: rho !< Cell-avg. density + real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: vel !< Cell-avg. velocity real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction @@ -622,7 +636,6 @@ contains type(vector_field) :: gm_alpha_qp real(wp) :: dt_local integer :: j, k, l !< Generic loop iterators - if (.not. igr .or. dummy) then call s_convert_conservative_to_primitive_variables(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, idwint) end if @@ -760,7 +773,6 @@ contains subroutine s_time_step_cycling(t_step) integer, intent(in) :: t_step integer :: i, j, k, l !< Generic loop iterator - if (t_step == t_step_start) then $:GPU_PARALLEL_LOOP(collapse=4) do i = 1, sys_size @@ -835,7 +847,6 @@ contains use hipfort_check #endif integer :: i, j !< Generic loop iterators - ! Deallocating the cell-average conservative variables #if defined(__NVCOMPILER_GPU_UNIFIED_MEM) do j = 1, sys_size diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 88f93b5ac5..a208b96001 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -6,12 +6,10 @@ !> @brief Computes viscous stress tensors and diffusive flux contributions for the Navier--Stokes equations module m_viscous - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_weno - use m_muscl !< Monotonic Upstream-centered (MUSCL) - !! schemes for conservation laws - + use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws use m_helper use m_finite_differences @@ -29,7 +27,6 @@ contains !> @brief Allocates and populates the viscous Reynolds number arrays and transfers data to the GPU. impure subroutine s_initialize_viscous_module integer :: i, j !< generic loop iterators - @:ALLOCATE(Res_viscous(1:2, 1:Re_size_max)) do i = 1, 2 @@ -55,7 +52,7 @@ contains type(scalar_field), dimension(num_dims), intent(in) :: grad_x_vf, grad_y_vf, grad_z_vf type(scalar_field), dimension(1:sys_size), intent(inout) :: tau_Re_vf type(int_bounds_info), intent(in) :: ix, iy, iz - real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables + real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables real(wp), dimension(2) :: Re_visc #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha_visc, alpha_rho_visc @@ -66,7 +63,6 @@ contains #:endif integer :: i, j, k, l, q !< Generic loop iterator - is1_viscous = ix; is2_viscous = iy; is3_viscous = iz $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous]') @@ -1072,7 +1068,6 @@ contains integer, intent(in) :: dim, buff_size_in real(wp), dimension(-buff_size_in:dim + buff_size_in), intent(in) :: dL integer :: i, j, k, l !< Generic loop iterators - is1_viscous = ix is2_viscous = iy is3_viscous = iz @@ -1166,7 +1161,6 @@ contains type(scalar_field), intent(inout) :: grad_z type(int_bounds_info) :: ix, iy, iz integer :: j, k, l !< Generic loop iterators - ix%beg = 1 - buff_size; ix%end = m + buff_size - 1 if (n > 0) then iy%beg = 1 - buff_size; iy%end = n + buff_size - 1 diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 1963c02a6c..b19dee2fc1 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -6,15 +6,13 @@ !> @brief WENO/WENO-Z/TENO reconstruction with optional monotonicity-preserving bounds and mapped weights module m_weno - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion !< State variables type conversion procedures - ! $:USE_GPU_MODULE() use m_mpi_proxy use m_muscl !< For Interface Compression - private; public :: s_initialize_weno_module, s_initialize_weno, s_finalize_weno_module, s_weno !> @name The cell-average variables that will be WENO-reconstructed. Formerly, they are stored in v_vf. However, they are @@ -111,7 +109,8 @@ contains @:ALLOCATE(d_cbL_x(0:weno_num_stencils, is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn)) @:ALLOCATE(d_cbR_x(0:weno_num_stencils, is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn)) - @:ALLOCATE(beta_coef_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + @:ALLOCATE(beta_coef_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, & + & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) ! Number of cross terms for dvd = (k-1)(k-1+1)/2, where weno_polyn = k-1 ! Note: k-1 not k because we are using value differences (dvd) not the values themselves @@ -139,7 +138,8 @@ contains @:ALLOCATE(d_cbL_y(0:weno_num_stencils, is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn)) @:ALLOCATE(d_cbR_y(0:weno_num_stencils, is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn)) - @:ALLOCATE(beta_coef_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + @:ALLOCATE(beta_coef_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, & + & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) call s_compute_weno_coefficients(2, is2_weno) @@ -158,7 +158,8 @@ contains @:ALLOCATE(d_cbL_z(0:weno_num_stencils, is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn)) @:ALLOCATE(d_cbR_z(0:weno_num_stencils, is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn)) - @:ALLOCATE(beta_coef_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + @:ALLOCATE(beta_coef_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, & + & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) call s_compute_weno_coefficients(3, is3_weno) @@ -173,13 +174,11 @@ contains integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is integer :: s - real(wp), pointer, dimension(:) :: s_cb => null() !< - !! Cell-boundary locations in the s-direction - - type(int_bounds_info) :: bc_s !< Boundary conditions (BC) in the s-direction - integer :: i !< Generic loop iterator - real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil - real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil + real(wp), pointer, dimension(:) :: s_cb => null() !< Cell-boundary locations in the s-direction + type(int_bounds_info) :: bc_s !< Boundary conditions (BC) in the s-direction + integer :: i !< Generic loop iterator + real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil + real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil ! Determining the number of cells, the cell-boundary locations and ! the boundary conditions in the coordinate direction selected for @@ -1196,10 +1195,14 @@ contains & + v(1)*(11003._wp*v(1) - 17246._wp*v(2) + 4642._wp*v(3)) + v(2) & & *(7043._wp*v(2) - 3882._wp*v(3)) + v(3)*(547._wp*v(3)))/240._wp + weno_eps !& - beta(4) = ( v(-3)*(547._wp*v(-3) - 3882._wp*v(-2) + 4642._wp*v(-1) - 1854._wp*v( 0)) & !& - + v(-2)*( 7043._wp*v(-2) - 17246._wp*v(-1) + 7042._wp*v( 0)) & !& - + v(-1)*( 11003._wp*v(-1) - 9402._wp*v( 0)) & !& - + v( 0)*( 2107._wp*v( 0)) ) / 240._wp & !& + beta(4) = ( v(-3)*(547._wp*v(-3) - 3882._wp*v(-2) + 4642._wp*v(-1) & + & - 1854._wp*v( 0)) & !& + + v(-2)*( 7043._wp*v(-2) - 17246._wp*v(-1) + 7042._wp*v( 0) & + & ) & !& + + v(-1)*( 11003._wp*v(-1) - 9402._wp*v( 0)) & + & & !& + + v( 0)*( 2107._wp*v( 0)) ) & + & / 240._wp & !& + weno_eps !& #:endif end if @@ -1408,9 +1411,7 @@ contains real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf, vR_rs_vf integer :: i, j, k, l real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers - real(wp) :: d_MD, d_LC !< - !! Median (md) curvature and large curvature (LC) measures - + real(wp) :: d_MD, d_LC !< Median (md) curvature and large curvature (LC) measures ! The left and right upper bounds (UL), medians, large curvatures, ! minima, and maxima of the WENO-reconstructed values of the cell- ! average variables. @@ -1425,10 +1426,9 @@ contains !! number less than 1/(1+alpha) is necessary. The default value for !! alpha is 2. - real(wp), parameter :: beta = 4._wp/3._wp !< - !! Determines the amount of freedom available from utilizing a large - !! value for the local curvature. The default value for beta is 4/3. - + !> Determines the amount of freedom available from utilizing a large value for the local curvature. The default value for + !! beta is 4/3. + real(wp), parameter :: beta = 4._wp/3._wp real(wp), parameter :: alpha_mp = 2._wp real(wp), parameter :: beta_mp = 4._wp/3._wp diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index baed0b4a2c..842f7be582 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -9,7 +9,7 @@ !! found in the work by Perigaud and Saurel (2005). Note that both viscous and capillarity effects are only available in the volume !! fraction model. program p_main - use m_global_parameters !< Definitions of the global parameters + use m_global_parameters !< Definitions of the global parameters use m_start_up use m_time_steppers use m_nvtx From 49353ad8f4391790523038cae648c3d536694671 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 11:50:51 -0400 Subject: [PATCH 04/25] Apply ffmt: blank line formatting, comment rewrapping, use/declaration alignment --- src/common/include/1dHardcodedIC.fpp | 8 +- src/common/include/2dHardcodedIC.fpp | 84 +- src/common/include/3dHardcodedIC.fpp | 10 +- src/common/include/macros.fpp | 21 +- src/common/m_boundary_common.fpp | 79 +- src/common/m_checker_common.fpp | 17 +- src/common/m_chemistry.fpp | 48 +- src/common/m_compile_specific.f90 | 19 + src/common/m_constants.fpp | 14 +- src/common/m_delay_file_access.f90 | 5 + src/common/m_derived_types.fpp | 47 +- src/common/m_finite_differences.fpp | 24 +- src/common/m_helper.fpp | 103 +- src/common/m_helper_basic.fpp | 31 +- src/common/m_model.fpp | 97 +- src/common/m_mpi_common.fpp | 207 ++-- src/common/m_nvtx.f90 | 14 +- src/common/m_phase_change.fpp | 151 ++- src/common/m_precision_select.f90 | 1 + src/common/m_variables_conversion.fpp | 231 ++-- src/post_process/m_checker.fpp | 10 +- src/post_process/m_data_input.f90 | 60 +- src/post_process/m_data_output.fpp | 423 +++---- src/post_process/m_derived_variables.fpp | 165 +-- src/post_process/m_global_parameters.fpp | 125 +- src/post_process/m_mpi_proxy.fpp | 76 +- src/post_process/m_start_up.fpp | 109 +- src/post_process/p_main.fpp | 17 +- src/pre_process/m_assign_variables.fpp | 109 +- src/pre_process/m_boundary_conditions.fpp | 19 +- src/pre_process/m_check_ib_patches.fpp | 97 +- src/pre_process/m_check_patches.fpp | 176 ++- src/pre_process/m_checker.fpp | 8 +- src/pre_process/m_data_output.fpp | 88 +- src/pre_process/m_global_parameters.fpp | 108 +- src/pre_process/m_grid.f90 | 28 +- src/pre_process/m_icpp_patches.fpp | 439 +++---- src/pre_process/m_initial_condition.fpp | 43 +- src/pre_process/m_mpi_proxy.fpp | 12 +- src/pre_process/m_perturbation.fpp | 52 +- src/pre_process/m_simplex_noise.fpp | 60 +- src/pre_process/m_start_up.fpp | 129 +- src/pre_process/p_main.f90 | 3 +- src/simulation/include/inline_riemann.fpp | 8 +- src/simulation/m_acoustic_src.fpp | 67 +- src/simulation/m_body_forces.fpp | 18 +- src/simulation/m_bubbles.fpp | 116 +- src/simulation/m_bubbles_EE.fpp | 43 +- src/simulation/m_bubbles_EL.fpp | 264 ++-- src/simulation/m_bubbles_EL_kernels.fpp | 93 +- src/simulation/m_cbc.fpp | 213 ++-- src/simulation/m_checker.fpp | 45 +- src/simulation/m_compute_cbc.fpp | 29 + src/simulation/m_compute_levelset.fpp | 40 +- src/simulation/m_data_output.fpp | 240 ++-- src/simulation/m_derived_variables.fpp | 109 +- src/simulation/m_fftw.fpp | 34 +- src/simulation/m_global_parameters.fpp | 128 +- src/simulation/m_hyperelastic.fpp | 102 +- src/simulation/m_hypoelastic.fpp | 144 ++- src/simulation/m_ib_patches.fpp | 189 +-- src/simulation/m_ibm.fpp | 187 +-- src/simulation/m_igr.fpp | 870 ++++++------- src/simulation/m_mpi_proxy.fpp | 19 +- src/simulation/m_muscl.fpp | 50 +- src/simulation/m_pressure_relaxation.fpp | 23 +- src/simulation/m_qbmm.fpp | 189 +-- src/simulation/m_rhs.fpp | 420 ++++--- src/simulation/m_riemann_solvers.fpp | 1377 +++++++++++---------- src/simulation/m_sim_helpers.fpp | 99 +- src/simulation/m_start_up.fpp | 139 ++- src/simulation/m_surface_tension.fpp | 53 +- src/simulation/m_time_steppers.fpp | 156 ++- src/simulation/m_viscous.fpp | 254 ++-- src/simulation/m_weno.fpp | 1150 +++++++++-------- src/simulation/p_main.fpp | 5 +- src/syscheck/syscheck.fpp | 3 + 77 files changed, 5873 insertions(+), 4570 deletions(-) diff --git a/src/common/include/1dHardcodedIC.fpp b/src/common/include/1dHardcodedIC.fpp index 311980c40e..7b100bced5 100644 --- a/src/common/include/1dHardcodedIC.fpp +++ b/src/common/include/1dHardcodedIC.fpp @@ -18,14 +18,14 @@ ! SDtoolbox) @: HardcodedReadValues() case (180) - ! This is patch is hard-coded for test suite optimization used in the - ! 1D_shuoser cases: "patch_icpp(2)%alpha_rho(1)": "1 + 0.2*sin(5*x)" + ! This is patch is hard-coded for test suite optimization used in the 1D_shuoser cases: "patch_icpp(2)%alpha_rho(1)": "1 + + ! 0.2*sin(5*x)" if (patch_id == 2) then q_prim_vf(contxb + 0)%sf(i, 0, 0) = 1 + 0.2*sin(5*x_cc(i)) end if case (181) - ! This is patch is hard-coded for test suite optimization used in the - ! 1D_titarevtorro cases: "patch_icpp(2)%alpha_rho(1)": "1 + 0.1*sin(20*x*pi)" + ! This is patch is hard-coded for test suite optimization used in the 1D_titarevtorro cases: "patch_icpp(2)%alpha_rho(1)": + ! "1 + 0.1*sin(20*x*pi)" q_prim_vf(contxb + 0)%sf(i, 0, 0) = 1 + 0.1*sin(20*x_cc(i)*pi) case (182) ! This patch is a hard-coded for test suite optimization (multiple component diffusion) diff --git a/src/common/include/2dHardcodedIC.fpp b/src/common/include/2dHardcodedIC.fpp index 183bcc059d..8b22aec882 100644 --- a/src/common/include/2dHardcodedIC.fpp +++ b/src/common/include/2dHardcodedIC.fpp @@ -153,11 +153,8 @@ q_prim_vf(advxe)%sf(i, j, 0) = alpha_air end if case (250) ! MHD Orszag-Tang vortex - ! gamma = 5/3 - ! rho = 25/(36*pi) - ! p = 5/(12*pi) - ! v = (-sin(2*pi*y), sin(2*pi*x), 0) - ! B = (-sin(2*pi*y)/sqrt(4*pi), sin(4*pi*x)/sqrt(4*pi), 0) + ! gamma = 5/3 rho = 25/(36*pi) p = 5/(12*pi) v = (-sin(2*pi*y), sin(2*pi*x), 0) B = (-sin(2*pi*y)/sqrt(4*pi), + ! sin(4*pi*x)/sqrt(4*pi), 0) q_prim_vf(momxb)%sf(i, j, 0) = -sin(2._wp*pi*y_cc(j)) q_prim_vf(momxb + 1)%sf(i, j, 0) = sin(2._wp*pi*x_cc(i)) @@ -180,28 +177,20 @@ ! case 252 is for the 2D MHD Rotor problem case (252) ! 2D MHD Rotor Problem - ! Ambient conditions are set in the JSON file. - ! This case imposes the dense, rotating cylinder. + ! Ambient conditions are set in the JSON file. This case imposes the dense, rotating cylinder. ! - ! gamma = 1.4 - ! Ambient medium (r > 0.1): - ! rho = 1, p = 1, v = 0, B = (1,0,0) - ! Rotor (r <= 0.1): - ! rho = 10, p = 1 - ! v has angular velocity w=20, giving v_tan=2 at r=0.1 + ! gamma = 1.4 Ambient medium (r > 0.1): rho = 1, p = 1, v = 0, B = (1,0,0) Rotor (r <= 0.1): rho = 10, p = 1 v has angular + ! velocity w=20, giving v_tan=2 at r=0.1 ! Calculate distance squared from the center r_sq = (x_cc(i) - 0.5_wp)**2 + (y_cc(j) - 0.5_wp)**2 ! inner radius of 0.1 if (r_sq <= 0.1**2) then - ! -- Inside the rotor -- - ! Set density uniformly to 10 + ! -- Inside the rotor -- Set density uniformly to 10 q_prim_vf(contxb)%sf(i, j, 0) = 10._wp - ! Set vup constant rotation of rate v=2 - ! v_x = -omega * (y - y_c) - ! v_y = omega * (x - x_c) + ! Set vup constant rotation of rate v=2 v_x = -omega * (y - y_c) v_y = omega * (x - x_c) q_prim_vf(momxb)%sf(i, j, 0) = -20._wp*(y_cc(j) - 0.5_wp) q_prim_vf(momxb + 1)%sf(i, j, 0) = 20._wp*(x_cc(i) - 0.5_wp) @@ -214,9 +203,8 @@ q_prim_vf(momxb + 1)%sf(i, j, 0) = (2._wp/sqrt(r_sq))*(x_cc(i) - 0.5_wp)*(0.115_wp - sqrt(r_sq))/(0.015_wp) end if case (253) ! MHD Smooth Magnetic Vortex - ! Section 5.2 of - ! Implicit hybridized discontinuous Galerkin methods for compressible magnetohydrodynamics - ! C. Ciuca, P. Fernandez, A. Christophe, N.C. Nguyen, J. Peraire + ! Section 5.2 of Implicit hybridized discontinuous Galerkin methods for compressible magnetohydrodynamics C. Ciuca, P. + ! Fernandez, A. Christophe, N.C. Nguyen, J. Peraire ! velocity q_prim_vf(momxb)%sf(i, j, 0) = 1._wp - (y_cc(j)*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/(2.*pi)) @@ -228,12 +216,11 @@ ! pressure q_prim_vf(E_idx)%sf(i, j, & - & 0) = 1._wp + (1 - 2._wp*(x_cc(i)**2 + y_cc(j)**2))*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/((2._wp*pi)**3) + & 0) = 1._wp + (1 - 2._wp*(x_cc(i)**2 + y_cc(j)**2))*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/((2._wp*pi)**3) case (260) ! Gaussian Divergence Pulse - ! Bx(x) = 1 + C * erf((x-0.5)/\sigma) - ! => \partialBx/\partialx = C * (2/\sqrt\pi) * exp[-((x-0.5)/\sigma)**2] * (1/\sigma) - ! Choose C = \epsilon * \sigma * \sqrt\pi / 2 => \partialBx/\partialx = \epsilon * exp[-((x-0.5)/\sigma)**2] - ! \psi is initialized to zero everywhere. + ! Bx(x) = 1 + C * erf((x-0.5)/\sigma) => \partialBx/\partialx = C * (2/\sqrt\pi) * exp[-((x-0.5)/\sigma)**2] * (1/\sigma) + ! Choose C = \epsilon * \sigma * \sqrt\pi / 2 => \partialBx/\partialx = \epsilon * exp[-((x-0.5)/\sigma)**2] \psi is + ! initialized to zero everywhere. eps_mhd = patch_icpp(patch_id)%a(2) sigma = patch_icpp(patch_id)%a(3) @@ -249,8 +236,8 @@ if (alpha < 1) then q_prim_vf(B_idx%beg)%sf(i, j, 0) = 1._wp/sqrt(4._wp*pi)*(alpha**8 - 2._wp*alpha**4 + 1._wp) ! q_prim_vf(B_idx%beg)%sf(i,j,0) = 1._wp/sqrt(4000._wp*pi) * (4096._wp*r2**4 - 128._wp*r2**2 + 1._wp) - ! q_prim_vf(B_idx%beg)%sf(i,j,0) = 1._wp/(4._wp*pi) * (alpha**8 - 2._wp*alpha**4 + 1._wp) - ! q_prim_vf(E_idx)%sf(i,j,0) = 6._wp - q_prim_vf(B_idx%beg)%sf(i,j,0)**2/2._wp + ! q_prim_vf(B_idx%beg)%sf(i,j,0) = 1._wp/(4._wp*pi) * (alpha**8 - 2._wp*alpha**4 + 1._wp) q_prim_vf(E_idx)%sf(i,j,0) = + ! 6._wp - q_prim_vf(B_idx%beg)%sf(i,j,0)**2/2._wp end if case (262) ! Tilted 2D MHD shock‐tube at α = arctan2 (≈63.4°) ! rotate by \alpha = atan(2) @@ -282,44 +269,41 @@ ! This hardcoded case extrudes a 1D profile to initialize a 2D simulation domain @: HardcodedReadValues() case (280) - ! This is patch is hard-coded for test suite optimization used in the - ! 2D_isentropicvortex case: - ! This analytic patch uses geometry 2 + ! This is patch is hard-coded for test suite optimization used in the 2D_isentropicvortex case: This analytic patch uses + ! geometry 2 if (patch_id == 1) then q_prim_vf(E_idx)%sf(i, j, & - & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & - & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**(1.4 + 1.0) + & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & + & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**(1.4 + 1.0) q_prim_vf(contxb + 0)%sf(i, j, & - & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & - & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**1.4 + & 0) = 1.0*(1.0 - (1.0/1.0)*(5.0/(2.0*pi))*(5.0/(8.0*1.0*(1.4 + 1.0)*pi))*exp(2.0*1.0*(1.0 - (x_cc(i) & + & - patch_icpp(1)%x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)))**1.4 q_prim_vf(momxb + 0)%sf(i, j, & - & 0) = 0.0 + (y_cc(j) - patch_icpp(1)%y_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & - & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) + & 0) = 0.0 + (y_cc(j) - patch_icpp(1)%y_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & + & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) q_prim_vf(momxb + 1)%sf(i, j, & - & 0) = 0.0 - (x_cc(i) - patch_icpp(1)%x_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & - & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) + & 0) = 0.0 - (x_cc(i) - patch_icpp(1)%x_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & + & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) end if case (281) - ! This is patch is hard-coded for test suite optimization used in the - ! 2D_acoustic_pulse case: - ! This analytic patch uses geometry 2 + ! This is patch is hard-coded for test suite optimization used in the 2D_acoustic_pulse case: This analytic patch uses + ! geometry 2 if (patch_id == 2) then q_prim_vf(E_idx)%sf(i, j, & - & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) + & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) q_prim_vf(contxb + 0)%sf(i, j, & - & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) + & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) end if case (282) - ! This is patch is hard-coded for test suite optimization used in the - ! 2D_zero_circ_vortex case: - ! This analytic patch uses geometry 2 + ! This is patch is hard-coded for test suite optimization used in the 2D_zero_circ_vortex case: This analytic patch uses + ! geometry 2 if (patch_id == 2) then q_prim_vf(E_idx)%sf(i, j, & - & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) + & 0) = 101325*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1.4/(1.4 - 1)) q_prim_vf(contxb + 0)%sf(i, j, & - & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) + & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.1/0.3)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) q_prim_vf(momxb + 0)%sf(i, j, & - & 0) = 112.99092883944267*(1 - (0.1/0.3))*y_cc(j)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) + & 0) = 112.99092883944267*(1 - (0.1/0.3))*y_cc(j)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) q_prim_vf(momxb + 1)%sf(i, j, 0) = 112.99092883944267*((0.1/0.3))*x_cc(i)*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))) end if case default diff --git a/src/common/include/3dHardcodedIC.fpp b/src/common/include/3dHardcodedIC.fpp index a689831dcb..07a6dca8eb 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -3,8 +3,7 @@ real(wp) :: rhoH, rhoL, pRef, pInt, h, lam, wl, amp, intH, alph, Mach real(wp) :: eps - ! IGR Jets - ! Arrays to stor position and radii of jets from input file + ! IGR Jets Arrays to stor position and radii of jets from input file real(wp), dimension(:), allocatable :: y_th_arr, z_th_arr, r_th_arr ! Variables to describe initial condition of jet real(wp) :: r, ux_th, ux_am, p_th, p_am, rho_th, rho_am, y_th, z_th, r_th, eps_smooth @@ -171,13 +170,12 @@ ! This hardcoded case extrudes a 2D profile to initialize a 3D simulation domain @: HardcodedReadValues() case (380) - ! This is patch is hard-coded for test suite optimization used in the - ! 3D_TaylorGreenVortex case: - ! This analytic patch used geometry 9 + ! This is patch is hard-coded for test suite optimization used in the 3D_TaylorGreenVortex case: This analytic patch used + ! geometry 9 Mach = 0.1 if (patch_id == 1) then q_prim_vf(E_idx)%sf(i, j, & - & k) = 101325 + (Mach**2*376.636429464809**2/16)*(cos(2*x_cc(i)/1) + cos(2*y_cc(j)/1))*(cos(2*z_cc(k)/1) + 2) + & k) = 101325 + (Mach**2*376.636429464809**2/16)*(cos(2*x_cc(i)/1) + cos(2*y_cc(j)/1))*(cos(2*z_cc(k)/1) + 2) q_prim_vf(momxb + 0)%sf(i, j, k) = Mach*376.636429464809*sin(x_cc(i)/1)*cos(y_cc(j)/1)*sin(z_cc(k)/1) q_prim_vf(momxb + 1)%sf(i, j, k) = -Mach*376.636429464809*cos(x_cc(i)/1)*sin(y_cc(j)/1)*sin(z_cc(k)/1) end if diff --git a/src/common/include/macros.fpp b/src/common/include/macros.fpp index 44af3ac6ab..3fc7e99cd0 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -12,19 +12,17 @@ #endif #:enddef -! Caution: -! This macro requires the use of a binding script to set CUDA_VISIBLE_DEVICES, such that we have one GPU device per MPI rank. -! That's because for both cudaMemAdvise (preferred location) and cudaMemPrefetchAsync we use location = device_id = 0. -! For an example see misc/nvidia_uvm/bind.sh. +! Caution: This macro requires the use of a binding script to set CUDA_VISIBLE_DEVICES, such that we have one GPU device per MPI +! rank. That's because for both cudaMemAdvise (preferred location) and cudaMemPrefetchAsync we use location = device_id = 0. For an +! example see misc/nvidia_uvm/bind.sh. #:def PREFER_GPU(*args) #ifdef MFC_SIMULATION #ifdef __NVCOMPILER_GPU_UNIFIED_MEM block - ! Beginning in the 25.3 release, the structure of the cudafor module has been changed slightly. - ! The module now includes, or "uses" 3 submodules: cuda_runtime_api, gpu_reductions, and sort. - ! The cudafor functionality has not changed. But for new users, or users who have needed to - ! work-around name conflicts in the module, it may be better to use cuda_runtime_api to expose - ! interfaces to the CUDA runtime calls described in Chapter 4 of this guide. + ! Beginning in the 25.3 release, the structure of the cudafor module has been changed slightly. The module now includes, or + ! "uses" 3 submodules: cuda_runtime_api, gpu_reductions, and sort. The cudafor functionality has not changed. But for new + ! users, or users who have needed to work-around name conflicts in the module, it may be better to use cuda_runtime_api to + ! expose interfaces to the CUDA runtime calls described in Chapter 4 of this guide. ! https://docs.nvidia.com/hpc-sdk/compilers/cuda-fortran-prog-guide/index.html#fortran-host-modules #if __NVCOMPILER_MAJOR__ < 25 || (__NVCOMPILER_MAJOR__ == 25 && __NVCOMPILER_MINOR__ < 3) use cudafor, gpu_sum => sum, gpu_maxval => maxval, gpu_minval => minval @@ -35,8 +33,7 @@ if (nv_uvm_pref_gpu) then #:for arg in args - ! print*, "Moving ${arg}$ to GPU => ", SHAPE(${arg}$) - ! set preferred location GPU + ! print*, "Moving ${arg}$ to GPU => ", SHAPE(${arg}$) set preferred location GPU istat = cudaMemAdvise(c_devloc(${arg}$), SIZEOF(${arg}$), cudaMemAdviseSetPreferredLocation, 0) if (istat /= cudaSuccess) then write (*, "('Error code: ',I0, ': ')") istat @@ -158,7 +155,7 @@ #:def ASSERT(predicate, message = None) if (.not. (${predicate}$)) then call s_mpi_abort("${_FILE_.split('/')[-1]}$:${_LINE_}$: " // "Assertion failed: ${predicate}$. " & - & // ${message or '"No error description."'}$) + & // ${message or '"No error description."'}$) end if #:enddef ! New line at end of file is required for FYPP diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index dd87622ebb..1fffd160b0 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -7,7 +7,8 @@ #:include 'macros.fpp' module m_boundary_common - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_mpi_proxy use m_constants @@ -35,10 +36,12 @@ module m_boundary_common #ifdef MFC_MPI public :: MPI_BC_TYPE_TYPE, MPI_BC_BUFFER_TYPE #endif + contains !> @brief Allocates and sets up boundary condition buffer arrays for all coordinate directions. impure subroutine s_initialize_boundary_common_module() + integer :: i, j @:ALLOCATE(bc_buffers(1:3, 1:2)) @@ -64,17 +67,20 @@ contains end do end do end if + end subroutine s_initialize_boundary_common_module !> The purpose of this procedure is to populate the buffers of the primitive variables, depending on the selected boundary !! conditions. impure subroutine s_populate_variables_buffers(bc_type, q_prim_vf, pb_in, mv_in) + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type integer :: k, l ! Population of Buffers in x-direction + if (bc_x%beg >= 0) then call s_mpi_sendrecv_variables_buffers(q_prim_vf, 1, -1, sys_size, pb_in, mv_in) else @@ -264,10 +270,12 @@ contains end if #:endif ! END: Population of Buffers in z-direction + end subroutine s_populate_variables_buffers !> @brief Fills ghost cells by copying the nearest boundary cell value along the specified direction. subroutine s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l) + $:GPU_ROUTINE(function_name='s_ghost_cell_extrapolation', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer, intent(in) :: bc_dir, bc_loc @@ -317,11 +325,13 @@ contains end do end if end if + end subroutine s_ghost_cell_extrapolation !> @brief Applies reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the normal velocity !! component. subroutine s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in @@ -345,7 +355,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(1, i))%sf(-j, k, l) = -q_prim_vf(shear_BC_flip_indices(1, & - & i))%sf(j - 1, k, l) + & i))%sf(j - 1, k, l) end do end if @@ -379,7 +389,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(1, i))%sf(m + j, k, l) = -q_prim_vf(shear_BC_flip_indices(1, & - & i))%sf(m - (j - 1), k, l) + & i))%sf(m - (j - 1), k, l) end do end if @@ -414,7 +424,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, -j, l) = -q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, & - & j - 1, l) + & j - 1, l) end do end if @@ -448,7 +458,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(2, i))%sf(k, n + j, l) = -q_prim_vf(shear_BC_flip_indices(2, & - & i))%sf(k, n - (j - 1), l) + & i))%sf(k, n - (j - 1), l) end do end if @@ -484,7 +494,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, -j) = -q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, & - & l, j - 1) + & l, j - 1) end do end if @@ -518,7 +528,7 @@ contains if (elasticity) then do i = 1, shear_BC_flip_num q_prim_vf(shear_BC_flip_indices(3, i))%sf(k, l, p + j) = -q_prim_vf(shear_BC_flip_indices(3, & - & i))%sf(k, l, p - (j - 1)) + & i))%sf(k, l, p - (j - 1)) end do end if @@ -539,10 +549,12 @@ contains end if end if end if + end subroutine s_symmetry !> @brief Applies periodic boundary conditions by copying values from the opposite domain boundary. subroutine s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in @@ -659,11 +671,13 @@ contains end if end if end if + end subroutine s_periodic !> @brief Applies axis boundary conditions for cylindrical coordinates by reflecting values across the axis with azimuthal phase !! shift. subroutine s_axis(q_prim_vf, pb_in, mv_in, k, l) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in @@ -708,10 +722,12 @@ contains end do end do end if + end subroutine s_axis !> @brief Applies slip wall boundary conditions by extrapolating scalars and reflecting the wall-normal velocity component. subroutine s_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l) + $:GPU_ROUTINE(function_name='s_slip_wall',parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer, intent(in) :: bc_dir, bc_loc @@ -785,10 +801,12 @@ contains end do end if end if + end subroutine s_slip_wall !> @brief Applies no-slip wall boundary conditions by reflecting and negating all velocity components at the wall. subroutine s_no_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l) + $:GPU_ROUTINE(function_name='s_no_slip_wall',parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -887,10 +905,12 @@ contains end do end if end if + end subroutine s_no_slip_wall !> @brief Applies Dirichlet boundary conditions by prescribing ghost cell values from stored boundary buffers. subroutine s_dirichlet(q_prim_vf, bc_dir, bc_loc, k, l) + $:GPU_ROUTINE(function_name='s_dirichlet',parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer, intent(in) :: bc_dir, bc_loc @@ -948,10 +968,12 @@ contains #else call s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l) #endif + end subroutine s_dirichlet !> @brief Extrapolates QBMM bubble pressure and mass-vapor variables into ghost cells by copying boundary values. subroutine s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in) + $:GPU_ROUTINE(parallelism='[seq]') real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in integer, intent(in) :: bc_dir, bc_loc @@ -1019,15 +1041,18 @@ contains end do end if end if + end subroutine s_qbmm_extrapolation !> @brief Populates ghost cell buffers for the color function and its divergence used in capillary surface tension. impure subroutine s_populate_capillary_buffers(c_divs, bc_type) + type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type integer :: k, l - !< x-direction + !> x-direction + if (bc_x%beg >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 1, -1, num_dims + 1) else @@ -1069,7 +1094,7 @@ contains if (n == 0) return #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - !< y-direction + !> y-direction if (bc_y%beg >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 2, -1, num_dims + 1) else @@ -1112,7 +1137,7 @@ contains if (p == 0) return #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - !< z-direction + !> z-direction if (bc_z%beg >= 0) then call s_mpi_sendrecv_variables_buffers(c_divs, 3, -1, num_dims + 1) else @@ -1151,10 +1176,12 @@ contains $:END_GPU_PARALLEL_LOOP() end if #:endif + end subroutine s_populate_capillary_buffers !> @brief Applies periodic boundary conditions to the color function and its divergence fields. subroutine s_color_function_periodic(c_divs, bc_dir, bc_loc, k, l) + $:GPU_ROUTINE(function_name='s_color_function_periodic', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs integer, intent(in) :: bc_dir, bc_loc @@ -1204,10 +1231,12 @@ contains end do end if end if + end subroutine s_color_function_periodic !> @brief Applies reflective boundary conditions to the color function and its divergence fields. subroutine s_color_function_reflective(c_divs, bc_dir, bc_loc, k, l) + $:GPU_ROUTINE(function_name='s_color_function_reflective', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs integer, intent(in) :: bc_dir, bc_loc @@ -1281,10 +1310,12 @@ contains end do end if end if + end subroutine s_color_function_reflective !> @brief Extrapolates the color function and its divergence into ghost cells by copying boundary values. subroutine s_color_function_ghost_cell_extrapolation(c_divs, bc_dir, bc_loc, k, l) + $:GPU_ROUTINE(function_name='s_color_function_ghost_cell_extrapolation', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs integer, intent(in) :: bc_dir, bc_loc @@ -1334,10 +1365,12 @@ contains end do end if end if + end subroutine s_color_function_ghost_cell_extrapolation !> @brief Populates ghost cell buffers for the Jacobian scalar field used in the IGR elliptic solver. impure subroutine s_populate_F_igr_buffers(bc_type, jac_sf) + type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type type(scalar_field), dimension(1:), intent(inout) :: jac_sf integer :: j, k, l @@ -1499,10 +1532,12 @@ contains $:END_GPU_PARALLEL_LOOP() end if #:endif + end subroutine s_populate_F_igr_buffers !> @brief Creates MPI derived datatypes for boundary condition type arrays and buffer arrays used in parallel I/O. impure subroutine s_create_mpi_types(bc_type) + type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type #ifdef MFC_MPI @@ -1516,7 +1551,7 @@ contains sf_extents_loc = shape(bc_type(dir, loc)%sf) call MPI_TYPE_CREATE_SUBARRAY(num_dims, sf_extents_loc, sf_extents_loc, sf_start_idx, MPI_ORDER_FORTRAN, & - & MPI_INTEGER, MPI_BC_TYPE_TYPE(dir, loc), ierr) + & MPI_INTEGER, MPI_BC_TYPE_TYPE(dir, loc), ierr) call MPI_TYPE_COMMIT(MPI_BC_TYPE_TYPE(dir, loc), ierr) end do end do @@ -1527,15 +1562,17 @@ contains sf_extents_loc = shape(bc_buffers(dir, loc)%sf) call MPI_TYPE_CREATE_SUBARRAY(num_dims, sf_extents_loc*mpi_io_type, sf_extents_loc*mpi_io_type, sf_start_idx, & - & MPI_ORDER_FORTRAN, mpi_io_p, MPI_BC_BUFFER_TYPE(dir, loc), ierr) + & MPI_ORDER_FORTRAN, mpi_io_p, MPI_BC_BUFFER_TYPE(dir, loc), ierr) call MPI_TYPE_COMMIT(MPI_BC_BUFFER_TYPE(dir, loc), ierr) end do end do #endif + end subroutine s_create_mpi_types !> @brief Writes boundary condition type and buffer data to serial (unformatted) restart files. subroutine s_write_serial_boundary_condition_files(q_prim_vf, bc_type, step_dirpath, old_grid_in) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type logical, intent(in) :: old_grid_in @@ -1569,10 +1606,12 @@ contains end do end do close (1) + end subroutine s_write_serial_boundary_condition_files !> @brief Writes boundary condition type and buffer data to per-rank parallel files using MPI I/O. subroutine s_write_parallel_boundary_condition_files(q_prim_vf, bc_type) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type integer :: dir, loc @@ -1632,10 +1671,12 @@ contains call MPI_File_close(file_id, ierr) #endif + end subroutine s_write_parallel_boundary_condition_files !> @brief Reads boundary condition type and buffer data from serial (unformatted) restart files. subroutine s_read_serial_boundary_condition_files(step_dirpath, bc_type) + character(LEN=*), intent(in) :: step_dirpath type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type integer :: dir, loc @@ -1644,6 +1685,7 @@ contains character(len=10) :: status ! Read bc_types + file_path = trim(step_dirpath) // '/bc_type.dat' inquire (FILE=trim(file_path), EXIST=file_exist) if (.not. file_exist) then @@ -1674,10 +1716,12 @@ contains end do end do close (1) + end subroutine s_read_serial_boundary_condition_files !> @brief Reads boundary condition type and buffer data from per-rank parallel files using MPI I/O. subroutine s_read_parallel_boundary_condition_files(bc_type) + type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type integer :: dir, loc character(len=path_len) :: file_loc, file_path @@ -1737,10 +1781,12 @@ contains call MPI_File_close(file_id, ierr) #endif + end subroutine s_read_parallel_boundary_condition_files !> @brief Packs primitive variable boundary slices into bc_buffers arrays for serialization. subroutine s_pack_boundary_condition_buffers(q_prim_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf integer :: i, j, k @@ -1778,10 +1824,12 @@ contains #:endif end if #:endif + end subroutine s_pack_boundary_condition_buffers !> @brief Initializes the per-cell boundary condition type arrays with the global default BC values. subroutine s_assign_default_bc_type(bc_type) + type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type bc_type(1, 1)%sf(:,:,:) = int(min(bc_x%beg, 0), kind=1) @@ -1802,15 +1850,18 @@ contains #:endif end if #:endif + end subroutine s_assign_default_bc_type !> The purpose of this subroutine is to populate the buffers of the grid variables, which are constituted of the cell- boundary !! locations and cell-width distributions, based on the boundary conditions. subroutine s_populate_grid_variables_buffers + integer :: i !< Generic loop iterator #ifdef MFC_SIMULATION ! Required for compatibility between codes type(int_bounds_info) :: offset_x, offset_y, offset_z + offset_x%beg = buff_size; offset_x%end = buff_size offset_y%beg = buff_size; offset_y%end = buff_size offset_z%beg = buff_size; offset_z%end = buff_size @@ -1986,10 +2037,12 @@ contains end do ! END: Population of Buffers in z-direction #endif + end subroutine s_populate_grid_variables_buffers !> @brief Deallocates boundary condition buffer arrays allocated during module initialization. subroutine s_finalize_boundary_common_module() + if (bc_io) then deallocate (bc_buffers(1, 1)%sf) deallocate (bc_buffers(1, 2)%sf) @@ -2008,5 +2061,7 @@ contains end if deallocate (bc_buffers) + end subroutine s_finalize_boundary_common_module + end module m_boundary_common diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index 0bc507f4a2..ee805e9bd9 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -7,30 +7,35 @@ !> @brief Shared input validation checks for grid dimensions and AMD GPU compiler limits module m_checker_common + use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none private; public :: s_check_inputs_common, wp + contains !> Checks compatibility of parameters in the input file. Used by all three stages impure subroutine s_check_inputs_common + #ifndef MFC_SIMULATION call s_check_total_cells #endif #:if USING_AMD call s_check_amd #:endif + end subroutine s_check_inputs_common #ifndef MFC_SIMULATION !> @brief Verifies that the total number of grid cells meets the minimum required by the number of dimensions and MPI ranks. impure subroutine s_check_total_cells + character(len=18) :: numStr !< for int to string conversion integer(kind=8) :: min_cells @@ -38,19 +43,21 @@ contains call s_int_to_str(2**(min(1, m) + min(1, n) + min(1, p))*num_procs, numStr) @:PROHIBIT(nGlobal < min_cells, & - & "Total number of cells must be at least (2^[number of dimensions])*num_procs, " // "which is currently " & - & // trim(numStr)) - end subroutine s_check_total_cells + & "Total number of cells must be at least (2^[number of dimensions])*num_procs, " // "which is currently " & + & // trim(numStr)) + end subroutine s_check_total_cells #endif !> @brief Checks that simulation parameters stay within AMD GPU compiler limits when case optimization is disabled. impure subroutine s_check_amd + #:if not MFC_CASE_OPTIMIZATION @:PROHIBIT(num_fluids > 3, "num_fluids <= 3 for AMDFLang when Case optimization is off") @:PROHIBIT((bubbles_euler .or. bubbles_lagrange) .and. nb > 3, "nb <= 3 for AMDFLang when Case optimization is off") @:PROHIBIT(chemistry .and. num_species /= 10, "num_species = 10 for AMDFLang when Case optimization is off") #:endif + end subroutine s_check_amd #ifndef MFC_POST_PROCESS diff --git a/src/common/m_chemistry.fpp b/src/common/m_chemistry.fpp index 51755b2762..c135052d06 100644 --- a/src/common/m_chemistry.fpp +++ b/src/common/m_chemistry.fpp @@ -8,6 +8,7 @@ !> @brief Multi-species chemistry interface for thermodynamic properties, reaction rates, and transport coefficients module m_chemistry + use m_thermochem, only: num_species, molecular_weights, get_temperature, get_net_production_rates, get_mole_fractions, & & get_species_binary_mass_diffusivities, get_species_mass_diffusivities_mixavg, gas_constant, & & get_mixture_molecular_weight, get_mixture_energy_mass, get_mixture_thermal_conductivity_mixavg, & @@ -19,7 +20,7 @@ module m_chemistry #:if USING_AMD real(wp) :: molecular_weights_nonparameter(10) = (/2.016, 1.008, 15.999, 31.998, 17.007, 18.015, 33.006, 34.014, 39.95, & - & 28.014/) + & 28.014/) $:GPU_DECLARE(create='[molecular_weights_nonparameter]') #:endif @@ -27,10 +28,12 @@ module m_chemistry $:GPU_DECLARE(create='[isc1, isc2, isc3]') integer, dimension(3) :: offsets $:GPU_DECLARE(create='[offsets]') + contains !> @brief Computes mixture viscosities for left and right states and inverts them for use as reciprocal Reynolds numbers. subroutine compute_viscosity_and_inversion(T_L, Ys_L, T_R, Ys_R, Re_L, Re_R) + $:GPU_ROUTINE(function_name='compute_viscosity_and_inversion',parallelism='[seq]', cray_inline=True) real(wp), intent(inout) :: T_L, T_R, Re_L, Re_R @@ -40,13 +43,14 @@ contains call get_mixture_viscosity_mixavg(T_R, Ys_R, Re_R) Re_L = 1.0_wp/Re_L Re_R = 1.0_wp/Re_R + end subroutine compute_viscosity_and_inversion !> @brief Initializes the temperature field from conservative variables by inverting the energy equation. subroutine s_compute_q_T_sf(q_T_sf, q_cons_vf, bounds) - ! Initialize the temperature field at the start of the simulation to - ! reasonable values. Temperature is computed the regular way using the - ! conservative variables. + + ! Initialize the temperature field at the start of the simulation to reasonable values. Temperature is computed the regular + ! way using the conservative variables. type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -62,10 +66,7 @@ contains Ys(eqn - chemxb + 1) = q_cons_vf(eqn)%sf(x, y, z)/q_cons_vf(contxb)%sf(x, y, z) end do - ! e = E - 1/2*|u|^2 - ! cons. E_idx = \rho E - ! cons. contxb = \rho (1-fluid model) - ! cons. momxb + i = \rho u_i + ! e = E - 1/2*|u|^2 cons. E_idx = \rho E cons. contxb = \rho (1-fluid model) cons. momxb + i = \rho u_i energy = q_cons_vf(E_idx)%sf(x, y, z)/q_cons_vf(contxb)%sf(x, y, z) do eqn = momxb, momxe energy = energy - 0.5_wp*(q_cons_vf(eqn)%sf(x, y, z)/q_cons_vf(contxb)%sf(x, y, z))**2._wp @@ -77,10 +78,12 @@ contains end do end do end do + end subroutine s_compute_q_T_sf !> @brief Computes the temperature field from primitive variables using the ideal gas law and mixture molecular weight. subroutine s_compute_T_from_primitives(q_T_sf, q_prim_vf, bounds) + type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(int_bounds_info), dimension(1:3), intent(in) :: bounds @@ -100,10 +103,12 @@ contains end do end do end do + end subroutine s_compute_T_from_primitives !> @brief Adds chemical reaction source terms to the species transport RHS using net production rates. subroutine s_compute_chemistry_reaction_flux(rhs_vf, q_cons_qp, q_T_sf, q_prim_qp, bounds) + type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_qp, q_prim_qp @@ -147,10 +152,12 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_compute_chemistry_reaction_flux !> @brief Computes species mass diffusion fluxes at cell interfaces using mixture-averaged diffusivities. subroutine s_compute_chemistry_diffusion_flux(idir, q_prim_qp, flux_src_vf, irx, iry, irz) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_qp type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf type(int_bounds_info), intent(in) :: irx, iry, irz @@ -188,9 +195,11 @@ contains if (chem_params%transport_model == 1) then ! Note: Added 'i' and 'eqn' to private list. $:GPU_PARALLEL_LOOP(collapse=3, private='[x, y, z, i, eqn, Ys_L, Ys_R, Ys_cell, Xs_L, Xs_R, & - & mass_diffusivities_mixavg1, mass_diffusivities_mixavg2, mass_diffusivities_mixavg_Cell, h_l, h_r, Xs_cell, h_k, & - & dXk_dxi, Mass_Diffu_Flux, Mass_Diffu_Energy, MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, T_L, T_R, P_L, P_R, & - & rho_L, rho_R, rho_cell, rho_Vic, lambda_L, lambda_R, lambda_Cell, dT_dxi, grid_spacing]', copyin='[offsets]') + & mass_diffusivities_mixavg1, mass_diffusivities_mixavg2, mass_diffusivities_mixavg_Cell, h_l, & + & h_r, Xs_cell, h_k, dXk_dxi, Mass_Diffu_Flux, Mass_Diffu_Energy, MW_L, MW_R, MW_cell, Rgas_L, & + & Rgas_R, T_L, T_R, P_L, P_R, rho_L, rho_R, rho_cell, rho_Vic, lambda_L, lambda_R, & + & lambda_Cell, & + & dT_dxi, grid_spacing]', copyin='[offsets]') do z = isc3%beg, isc3%end do y = isc2%beg, isc2%end do x = isc1%beg, isc1%end @@ -267,7 +276,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe mass_diffusivities_mixavg_Cell(i - chemxb + 1) = (mass_diffusivities_mixavg2(i - chemxb + 1) & - & + mass_diffusivities_mixavg1(i - chemxb + 1))/2.0_wp + & + mass_diffusivities_mixavg1(i - chemxb + 1))/2.0_wp end do lambda_Cell = 0.5_wp*(lambda_R + lambda_L) @@ -280,10 +289,11 @@ contains do eqn = chemxb, chemxe #:if USING_AMD Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*mass_diffusivities_mixavg_Cell(eqn - chemxb + 1) & - & *molecular_weights_nonparameter(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) + & *molecular_weights_nonparameter(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn & + & - chemxb + 1) #:else Mass_Diffu_Flux(eqn - chemxb + 1) = rho_cell*mass_diffusivities_mixavg_Cell(eqn - chemxb + 1) & - & *molecular_weights(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) + & *molecular_weights(eqn - chemxb + 1)/MW_cell*dXk_dxi(eqn - chemxb + 1) #:endif rho_Vic = rho_Vic + Mass_Diffu_Flux(eqn - chemxb + 1) Mass_Diffu_Energy = Mass_Diffu_Energy + h_k(eqn - chemxb + 1)*Mass_Diffu_Flux(eqn - chemxb + 1) @@ -294,7 +304,7 @@ contains do eqn = chemxb, chemxe Mass_Diffu_Energy = Mass_Diffu_Energy - h_k(eqn - chemxb + 1)*Ys_cell(eqn - chemxb + 1)*rho_Vic Mass_Diffu_Flux(eqn - chemxb + 1) = Mass_Diffu_Flux(eqn - chemxb + 1) - rho_Vic*Ys_cell(eqn & - & - chemxb + 1) + & - chemxb + 1) end do ! Add thermal conduction contribution @@ -316,9 +326,9 @@ contains else if (chem_params%transport_model == 2) then ! Note: Added ALL scalars and 'i'/'eqn' to private list to prevent race conditions. $:GPU_PARALLEL_LOOP(collapse=3, private='[x, y, z, i, eqn, Ys_L, Ys_R, Ys_cell, dYk_dxi, Mass_Diffu_Flux, & - & grid_spacing, MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, P_L, P_R, rho_L, rho_R, rho_cell, T_L, T_R, Cp_L, Cp_R, & - & hmix_L, hmix_R, dh_dxi, lambda_L, lambda_R, lambda_Cell, diffusivity_L, diffusivity_R, diffusivity_cell, & - & Mass_Diffu_Energy]', copyin='[offsets]') + & grid_spacing, MW_L, MW_R, MW_cell, Rgas_L, Rgas_R, P_L, P_R, rho_L, rho_R, rho_cell, T_L, & + & T_R, Cp_L, Cp_R, hmix_L, hmix_R, dh_dxi, lambda_L, lambda_R, lambda_Cell, diffusivity_L, & + & diffusivity_R, diffusivity_cell, Mass_Diffu_Energy]', copyin='[offsets]') do z = isc3%beg, isc3%end do y = isc2%beg, isc2%end do x = isc1%beg, isc1%end @@ -405,5 +415,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if + end subroutine s_compute_chemistry_diffusion_flux + end module m_chemistry diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index 02598b8237..da6158e972 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -4,69 +4,86 @@ !> @brief Platform-specific file and directory operations: create, delete, inquire, getcwd, and basename module m_compile_specific + ! Dependencies use m_mpi_proxy implicit none + contains !> Creates a directory and all its parents if it does not exist !! @param dir_name Directory path impure subroutine s_create_directory(dir_name) + character(LEN=*), intent(in) :: dir_name #ifdef _WIN32 + call system('mkdir "' // dir_name // '" 2> NUL') #else call system('mkdir -p "' // dir_name // '"') #endif + end subroutine s_create_directory !> @brief Deletes a file at the given path using a platform-specific system command. impure subroutine s_delete_file(filepath) + character(LEN=*), intent(in) :: filepath #ifdef _WIN32 + call system('del "' // filepath // '"') #else call system('rm "' // filepath // '"') #endif + end subroutine s_delete_file !> @brief Recursively deletes a directory using a platform-specific system command. impure subroutine s_delete_directory(dir_name) + character(LEN=*), intent(in) :: dir_name #ifdef _WIN32 + call system('rmdir "' // dir_name // '" /s /q') #else call system('rm -r "' // dir_name // '"') #endif + end subroutine s_delete_directory !> Inquires on the existence of a directory !! @param fileloc File directory location !! @param dircheck Switch that indicates if directory exists impure subroutine my_inquire(fileloc, dircheck) + character(LEN=*), intent(in) :: fileloc logical, intent(inout) :: dircheck #ifdef __INTEL_COMPILER + inquire (DIRECTORY=trim(fileloc), EXIST=dircheck) ! Intel #else inquire (FILE=trim(fileloc), EXIST=dircheck) ! GCC #endif + end subroutine my_inquire !> @brief Retrieves the current working directory path via the GETCWD intrinsic. impure subroutine s_get_cwd(cwd) + character(LEN=*), intent(out) :: cwd call GETCWD(cwd) + end subroutine s_get_cwd !> @brief Extracts the base filename from a directory path using the system basename command. impure subroutine s_get_basename(dirpath, basename) + character(LEN=*), intent(in) :: dirpath character(LEN=*), intent(out) :: basename integer :: iUnit @@ -85,5 +102,7 @@ impure subroutine s_get_basename(dirpath, basename) close (iUnit) call s_delete_file(trim(tmpfilepath)) + end subroutine s_get_basename + end module m_compile_specific diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index bd3e352dde..790d97ea1d 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -4,6 +4,7 @@ !> @brief Compile-time constant parameters: default values, tolerances, and physical constants module m_constants + use m_precision_select character, parameter :: dflt_char = ' ' !< Default string value @@ -66,8 +67,7 @@ module m_constants real(wp), parameter :: dflt_adap_dt_tol = 1.e-4_wp !< Default tolerance for adaptive step size integer, parameter :: dflt_adap_dt_max_iters = 100 !< Default max iteration for adaptive step size ! Constants of the algorithm described by Heirer, E. Hairer, S. P.Norsett, G. Wanner, Solving Ordinary Differential Equations I, - ! Chapter II.4 - ! to choose the initial time step size for the adaptive time stepping routine + ! Chapter II.4 to choose the initial time step size for the adaptive time stepping routine real(wp), parameter :: threshold_first_guess = 1.e-5_wp real(wp), parameter :: threshold_second_guess = 1.e-15_wp real(wp), parameter :: scale_first_guess = 1.e-3_wp @@ -87,14 +87,8 @@ module m_constants ! System constants integer, parameter :: CASE_FILE_ERROR_CODE = 22 - ! Boundary condition enumeration - ! Abbreviations - ! CHAR - Characteristic - ! NR - Non-reflecting - ! SUB - subsonic - ! SUP - supersonic - ! FF - Force-free - ! CP - Constant pressure + ! Boundary condition enumeration Abbreviations CHAR - Characteristic NR - Non-reflecting SUB - subsonic SUP - supersonic FF - + ! Force-free CP - Constant pressure integer, parameter :: BC_PERIODIC = -1 integer, parameter :: BC_REFLECTIVE = -2 integer, parameter :: BC_GHOST_EXTRAP = -3 diff --git a/src/common/m_delay_file_access.f90 b/src/common/m_delay_file_access.f90 index f567ccb1a7..eb7cbf2f1f 100644 --- a/src/common/m_delay_file_access.f90 +++ b/src/common/m_delay_file_access.f90 @@ -4,6 +4,7 @@ !> @brief Rank-staggered file access delays to prevent I/O contention on parallel file systems module m_delay_file_access + use m_precision_select implicit none private @@ -11,10 +12,12 @@ module m_delay_file_access public :: DelayFileAccess integer, private, parameter :: N_PROCESSES_FILE_ACCESS = 128, FILE_ACCESS_DELAY_UNIT = 10000 + contains !> @brief Introduces a rank-dependent busy-wait delay to stagger parallel file access and reduce I/O contention. impure subroutine DelayFileAccess(ProcessRank) + integer, intent(in) :: ProcessRank integer :: iDelay, nFileAccessDelayIterations real(wp) :: Number, Dummy @@ -26,5 +29,7 @@ impure subroutine DelayFileAccess(ProcessRank) call random_number(Number) Dummy = Number*Number end do + end subroutine DelayFileAccess + end module m_delay_file_access diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 948803e75d..d9ff1782ee 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -6,6 +6,7 @@ !> @brief Shared derived types for field data, patch geometry, bubble dynamics, and MPI I/O structures module m_derived_types + use m_constants !< Constants use m_precision_select use m_thermochem, only: num_species @@ -193,16 +194,16 @@ module m_derived_types real(wp) :: radius !< Dimensions of the patch. radius. !> Vector indicating the various radii for the elliptical and ellipsoidal patch geometries. It is specified through its x-, !! y-, and z-components respectively. - real(wp), dimension(3) :: radii - real(wp) :: epsilon, beta !< The isentropic vortex parameters for the amplitude of the disturbance and domain of influence. + real(wp), dimension(3) :: radii + real(wp) :: epsilon, beta !< The isentropic vortex parameters for the amplitude of the disturbance and domain of influence. real(wp), dimension(2:9) :: a !< Used by hardcoded IC and as temporary variables. - logical :: non_axis_sym + logical :: non_axis_sym ! Geometry 13 (2D modal Fourier): fourier_cos(n), fourier_sin(n) for mode n real(wp), dimension(1:max_2d_fourier_modes) :: fourier_cos, fourier_sin - logical :: modal_clip_r_to_min !< When true, clip boundary radius: R(theta) = max(R(theta), modal_r_min) (Non-exp form only) - real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) - logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) + logical :: modal_clip_r_to_min !< When true, clip boundary radius: R(theta) = max(R(theta), modal_r_min) (Non-exp form only) + real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) + logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) ! Geometry 14 (3D spherical harmonic): sph_har_coeff(l,m) for real Y_lm real(wp), dimension(0:max_sph_harm_degree, -max_sph_harm_degree:max_sph_harm_degree) :: sph_har_coeff !> Normal vector indicating the orientation of the patch. It is specified through its x-, y- and z-components, respectively. @@ -243,11 +244,11 @@ module m_derived_types !! STL or OBJ model input parameter character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. - real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. - real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. - real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. - integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. - real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. + real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. + real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. + real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. end type ic_patch_parameters type ib_patch_parameters @@ -272,18 +273,18 @@ module m_derived_types !! STL or OBJ model input parameter character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. - real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. - real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. - real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. - integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. - real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. Patch conditions for moving imersed boundaries - integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path - real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling - real(wp), dimension(1:3) :: force, torque ! vectors for the computed force and torque values applied to an IB - real(wp), dimension(1:3) :: vel - real(wp), dimension(1:3) :: step_vel ! velocity array used to store intermediate steps in the time_stepper module - real(wp), dimension(1:3) :: angular_vel - real(wp), dimension(1:3) :: step_angular_vel ! velocity array used to store intermediate steps in the time_stepper module + real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. + real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. + real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. Patch conditions for moving imersed boundaries + integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path + real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling + real(wp), dimension(1:3) :: force, torque ! vectors for the computed force and torque values applied to an IB + real(wp), dimension(1:3) :: vel + real(wp), dimension(1:3) :: step_vel ! velocity array used to store intermediate steps in the time_stepper module + real(wp), dimension(1:3) :: angular_vel + real(wp), dimension(1:3) :: step_angular_vel ! velocity array used to store intermediate steps in the time_stepper module end type ib_patch_parameters !> Derived type annexing the physical parameters (PP) of the fluids. These include the specific heat ratio function and liquid diff --git a/src/common/m_finite_differences.fpp b/src/common/m_finite_differences.fpp index 9d1dc83788..4f979ce2e3 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -6,12 +6,15 @@ !> @brief Finite difference operators for computing divergence of velocity fields module m_finite_differences + use m_global_parameters implicit none + contains subroutine s_compute_fd_divergence(div, fields, ix_s, iy_s, iz_s) + type(scalar_field), intent(inout) :: div type(scalar_field), intent(in) :: fields(1:3) type(int_bounds_info), intent(in) :: ix_s, iy_s, iz_s @@ -24,10 +27,10 @@ contains do z = iz_s%beg, iz_s%end if (x == ix_s%beg) then divergence = (-3._wp*fields(1)%sf(x, y, z) + 4._wp*fields(1)%sf(x + 1, y, z) - fields(1)%sf(x + 2, y, & - & z))/(x_cc(x + 2) - x_cc(x)) + & z))/(x_cc(x + 2) - x_cc(x)) else if (x == ix_s%end) then divergence = (+3._wp*fields(1)%sf(x, y, z) - 4._wp*fields(1)%sf(x - 1, y, z) + fields(1)%sf(x - 2, y, & - & z))/(x_cc(x) - x_cc(x - 2)) + & z))/(x_cc(x) - x_cc(x - 2)) else divergence = (fields(1)%sf(x + 1, y, z) - fields(1)%sf(x - 1, y, z))/(x_cc(x + 1) - x_cc(x - 1)) end if @@ -35,26 +38,26 @@ contains if (n > 0) then if (y == iy_s%beg) then divergence = divergence + (-3._wp*fields(2)%sf(x, y, z) + 4._wp*fields(2)%sf(x, y + 1, & - & z) - fields(2)%sf(x, y + 2, z))/(y_cc(y + 2) - y_cc(y)) + & z) - fields(2)%sf(x, y + 2, z))/(y_cc(y + 2) - y_cc(y)) else if (y == iy_s%end) then divergence = divergence + (+3._wp*fields(2)%sf(x, y, z) - 4._wp*fields(2)%sf(x, y - 1, & - & z) + fields(2)%sf(x, y - 2, z))/(y_cc(y) - y_cc(y - 2)) + & z) + fields(2)%sf(x, y - 2, z))/(y_cc(y) - y_cc(y - 2)) else divergence = divergence + (fields(2)%sf(x, y + 1, z) - fields(2)%sf(x, y - 1, & - & z))/(y_cc(y + 1) - y_cc(y - 1)) + & z))/(y_cc(y + 1) - y_cc(y - 1)) end if end if if (p > 0) then if (z == iz_s%beg) then divergence = divergence + (-3._wp*fields(3)%sf(x, y, z) + 4._wp*fields(3)%sf(x, y, & - & z + 1) - fields(3)%sf(x, y, z + 2))/(z_cc(z + 2) - z_cc(z)) + & z + 1) - fields(3)%sf(x, y, z + 2))/(z_cc(z + 2) - z_cc(z)) else if (z == iz_s%end) then divergence = divergence + (+3._wp*fields(3)%sf(x, y, z) - 4._wp*fields(3)%sf(x, y, & - & z - 1) + fields(3)%sf(x, y, z - 2))/(z_cc(z) - z_cc(z - 2)) + & z - 1) + fields(3)%sf(x, y, z - 2))/(z_cc(z) - z_cc(z - 2)) else divergence = divergence + (fields(3)%sf(x, y, z + 1) - fields(3)%sf(x, y, & - & z - 1))/(z_cc(z + 1) - z_cc(z - 1)) + & z - 1))/(z_cc(z + 1) - z_cc(z - 1)) end if end if @@ -63,6 +66,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_compute_fd_divergence !> The purpose of this subroutine is to compute the finite- difference coefficients for the centered schemes utilized in @@ -77,6 +81,7 @@ contains !! @param fd_order_in Finite-difference order of accuracy !! @param offset_s Optional offset bounds in the s-coordinate direction subroutine s_compute_finite_difference_coefficients(q, s_cc, fd_coeff_s, local_buff_size, fd_number_in, fd_order_in, offset_s) + integer :: lB, lE !< loop bounds integer, intent(in) :: q integer, intent(in) :: local_buff_size, fd_number_in, fd_order_in @@ -84,6 +89,7 @@ contains real(wp), allocatable, dimension(:,:), intent(inout) :: fd_coeff_s real(wp), dimension(-local_buff_size:q + local_buff_size), intent(in) :: s_cc integer :: i !< Generic loop iterator + if (present(offset_s)) then lB = -offset_s%beg lE = q + offset_s%end @@ -123,5 +129,7 @@ contains fd_coeff_s(2, i) = -fd_coeff_s(-2, i) end do end if + end subroutine s_compute_finite_difference_coefficients + end module m_finite_differences diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index 34e2d02f7e..e8b0118066 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -7,9 +7,10 @@ !> @brief Utility routines for bubble model setup, coordinate transforms, array sampling, and special functions module m_helper - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters - use ieee_arithmetic !< For checking NaN + use ieee_arithmetic !< For checking NaN implicit none private; @@ -17,14 +18,16 @@ module m_helper & s_int_to_str, s_transform_vec, s_transform_triangle, s_transform_model, s_swap, f_cross, f_create_transform_matrix, & & f_create_bbox, s_print_2D_array, f_xor, f_logical_to_int, associated_legendre, real_ylm, double_factorial, factorial, & & f_cut_on, f_cut_off, s_downsample_data, s_upsample_data + contains !> Computes the bubble number density n from the primitive variables - !! @param vftmp is the void fraction - !! @param Rtmp is the bubble radii - !! @param ntmp is the output number bubble density - !! @param weights is the quadrature weights + !! @param vftmp is the void fraction + !! @param Rtmp is the bubble radii + !! @param ntmp is the output number bubble density + !! @param weights is the quadrature weights subroutine s_comp_n_from_prim(vftmp, Rtmp, ntmp, weights) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: vftmp real(wp), dimension(nb), intent(in) :: Rtmp @@ -34,10 +37,12 @@ contains R3 = dot_product(weights, Rtmp**3._wp) ntmp = (3._wp/(4._wp*pi))*vftmp/R3 + end subroutine s_comp_n_from_prim !> @brief Computes the bubble number density from the conservative void fraction and weighted bubble radii. subroutine s_comp_n_from_cons(vftmp, nRtmp, ntmp, weights) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: vftmp real(wp), dimension(nb), intent(in) :: nRtmp @@ -47,10 +52,12 @@ contains nR3 = dot_product(weights, nRtmp**3._wp) ntmp = sqrt((4._wp*pi/3._wp)*nR3/vftmp) + end subroutine s_comp_n_from_cons !> @brief Prints a 2D real array to standard output, optionally dividing each element by a given scalar. impure subroutine s_print_2D_array(A, div) + real(wp), dimension(:,:), intent(in) :: A real(wp), optional, intent(in) :: div integer :: i, j @@ -75,10 +82,12 @@ contains write (*, fmt="(A1)") " " end do write (*, fmt="(A1)") " " + end subroutine s_print_2D_array !> bubbles_euler + polytropic bubbles_euler + non-polytropic bubbles_lagrange + non-polytropic impure subroutine s_initialize_bubbles_model() + ! Allocate memory if (bubbles_euler) then @:ALLOCATE(weight(nb), R0(nb)) @@ -103,10 +112,12 @@ contains ! Initialize bubble variables call s_initialize_bubble_vars() + end subroutine s_initialize_bubbles_model !> impure subroutine s_initialize_bubble_vars() + R0ref = bub_pp%R0ref; p0ref = bub_pp%p0ref rho0ref = bub_pp%rho0ref; ss = bub_pp%ss; pv = bub_pp%pv; vd = bub_pp%vd @@ -154,14 +165,17 @@ contains end if end if end if + end subroutine s_initialize_bubble_vars !> Initializes non-polydisperse bubble modeling impure subroutine s_initialize_nonpoly() + integer :: ir real(wp), dimension(nb) :: chi_vw0, cp_m0, k_m0, rho_m0, x_vw, omegaN, rhol0 real(wp), parameter :: k_poly = 1._wp !< polytropic index used to compute isothermal natural frequency ! phi_vg & phi_gv (phi_gg = phi_vv = 1) (Eq. 2.22 in Ando 2010) + phi_vg = (1._wp + sqrt(mu_v/mu_g)*(M_g/M_v)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_v/M_g)) phi_gv = (1._wp + sqrt(mu_g/mu_v)*(M_v/M_g)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_g/M_v)) @@ -199,14 +213,16 @@ contains call s_transcoeff(omegaN(ir)*R0(ir), Pe_c*R0(ir), Re_trans_c(ir), Im_trans_c(ir)) end do Im_trans_T = 0._wp + end subroutine s_initialize_nonpoly !> Computes the transfer coefficient for the non-polytropic bubble compression process - !! @param omega natural frequencies - !! @param peclet Peclet number - !! @param Re_trans Real part of the transport coefficients - !! @param Im_trans Imaginary part of the transport coefficients + !! @param omega natural frequencies + !! @param peclet Peclet number + !! @param Re_trans Real part of the transport coefficients + !! @param Im_trans Imaginary part of the transport coefficients elemental subroutine s_transcoeff(omega, peclet, Re_trans, Im_trans) + real(wp), intent(in) :: omega, peclet real(wp), intent(out) :: Re_trans, Im_trans complex(wp) :: imag, trans, c1, c2, c3 @@ -220,19 +236,23 @@ contains Re_trans = trans Im_trans = aimag(trans) + end subroutine s_transcoeff !> @brief Converts an integer to its trimmed string representation. elemental subroutine s_int_to_str(i, res) + integer, intent(in) :: i character(len=*), intent(inout) :: res write (res, '(I0)') i res = trim(res) + end subroutine s_int_to_str !> Computes the Simpson weights for quadrature subroutine s_simpson(local_weight, local_R0) + real(wp), dimension(:), intent(inout) :: local_weight real(wp), dimension(:), intent(inout) :: local_R0 integer :: ir @@ -267,6 +287,7 @@ contains local_weight(1) = tmp*dphi/3._wp tmp = exp(-0.5_wp*(phi(nb)/sd)**2)/sqrt(2._wp*pi)/sd local_weight(nb) = tmp*dphi/3._wp + end subroutine s_simpson !> This procedure computes the cross product of two vectors. @@ -274,6 +295,7 @@ contains !! @param b Second vector. !! @return The cross product of the two vectors. pure function f_cross(a, b) result(c) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(3), intent(in) :: a, b @@ -282,18 +304,21 @@ contains c(1) = a(2)*b(3) - a(3)*b(2) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) + end function f_cross !> This procedure swaps two real numbers. !! @param lhs Left-hand side. !! @param rhs Right-hand side. elemental subroutine s_swap(lhs, rhs) + real(wp), intent(inout) :: lhs, rhs real(wp) :: ltemp ltemp = lhs lhs = rhs rhs = ltemp + end subroutine s_swap !> This procedure creates a transformation matrix. @@ -301,50 +326,54 @@ contains !! @param center Optional center point for the transformation. !! @return Transformation matrix. function f_create_transform_matrix(param, center) result(out_matrix) + type(ic_model_parameters), intent(in) :: param real(wp), dimension(1:3), optional, intent(in) :: center real(wp), dimension(1:4, 1:4) :: sc, rz, rx, ry, tr, t_back, t_to_origin, out_matrix sc = transpose(reshape([param%scale(1), 0._wp, 0._wp, 0._wp, 0._wp, param%scale(2), 0._wp, 0._wp, 0._wp, 0._wp, & - & param%scale(3), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(sc))) + & param%scale(3), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(sc))) rz = transpose(reshape([cos(param%rotate(3)), -sin(param%rotate(3)), 0._wp, 0._wp, sin(param%rotate(3)), & - & cos(param%rotate(3)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp, 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rz))) + & cos(param%rotate(3)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp, 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rz))) rx = transpose(reshape([1._wp, 0._wp, 0._wp, 0._wp, 0._wp, cos(param%rotate(1)), -sin(param%rotate(1)), 0._wp, 0._wp, & - & sin(param%rotate(1)), cos(param%rotate(1)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rx))) + & sin(param%rotate(1)), cos(param%rotate(1)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(rx))) ry = transpose(reshape([cos(param%rotate(2)), 0._wp, sin(param%rotate(2)), 0._wp, 0._wp, 1._wp, 0._wp, 0._wp, & - & -sin(param%rotate(2)), 0._wp, cos(param%rotate(2)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(ry))) + & -sin(param%rotate(2)), 0._wp, cos(param%rotate(2)), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(ry))) tr = transpose(reshape([1._wp, 0._wp, 0._wp, param%translate(1), 0._wp, 1._wp, 0._wp, param%translate(2), 0._wp, 0._wp, & - & 1._wp, param%translate(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + & 1._wp, param%translate(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) if (present(center)) then ! Translation matrix to move center to the origin t_to_origin = transpose(reshape([1._wp, 0._wp, 0._wp, -center(1), 0._wp, 1._wp, 0._wp, -center(2), 0._wp, 0._wp, & - & 1._wp, -center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + & 1._wp, -center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) ! Translation matrix to move center back to original position t_back = transpose(reshape([1._wp, 0._wp, 0._wp, center(1), 0._wp, 1._wp, 0._wp, center(2), 0._wp, 0._wp, 1._wp, & - & center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) + & center(3), 0._wp, 0._wp, 0._wp, 1._wp], shape(tr))) out_matrix = matmul(tr, matmul(t_back, matmul(ry, matmul(rx, matmul(rz, matmul(sc, t_to_origin)))))) else out_matrix = matmul(ry, matmul(rx, rz)) end if + end function f_create_transform_matrix !> This procedure transforms a vector by a matrix. !! @param vec Vector to transform. !! @param matrix Transformation matrix. subroutine s_transform_vec(vec, matrix) + real(wp), dimension(1:3), intent(inout) :: vec real(wp), dimension(1:4, 1:4), intent(in) :: matrix real(wp), dimension(1:4) :: tmp tmp = matmul(matrix, [vec(1), vec(2), vec(3), 1._wp]) vec = tmp(1:3) + end subroutine s_transform_vec !> This procedure transforms a triangle by a matrix, one vertex at a time. @@ -352,6 +381,7 @@ contains !! @param matrix Transformation matrix. !! @param matrix_n Normal transformation matrix. subroutine s_transform_triangle(triangle, matrix, matrix_n) + type(t_triangle), intent(inout) :: triangle real(wp), dimension(1:4, 1:4), intent(in) :: matrix, matrix_n integer :: i @@ -361,6 +391,7 @@ contains end do call s_transform_vec(triangle%n(1:3), matrix_n) + end subroutine s_transform_triangle !> This procedure transforms a model by a matrix, one triangle at a time. @@ -368,6 +399,7 @@ contains !! @param matrix Transformation matrix. !! @param matrix_n Normal transformation matrix. subroutine s_transform_model(model, matrix, matrix_n) + type(t_model), intent(inout) :: model real(wp), dimension(1:4, 1:4), intent(in) :: matrix, matrix_n integer :: i @@ -375,12 +407,14 @@ contains do i = 1, size(model%trs) call s_transform_triangle(model%trs(i), matrix, matrix_n) end do + end subroutine s_transform_model !> This procedure creates a bounding box for a model. !! @param model Model to create bounding box for. !! @return Bounding box. function f_create_bbox(model) result(bbox) + type(t_model), intent(in) :: model type(t_bbox) :: bbox integer :: i, j @@ -400,6 +434,7 @@ contains bbox%max = max(bbox%max, model%trs(i)%v(j,:)) end do end do + end function f_create_bbox !> This procedure performs xor on lhs and rhs. @@ -407,16 +442,19 @@ contains !! @param rhs other logical input. !! @return xored result. elemental function f_xor(lhs, rhs) result(res) + logical, intent(in) :: lhs, rhs logical :: res res = (lhs .and. .not. rhs) .or. (.not. lhs .and. rhs) + end function f_xor !> This procedure converts logical to 1 or 0. !! @param predicate A Logical argument. !! @return 1 if .true., 0 if .false.. elemental function f_logical_to_int(predicate) result(int) + logical, intent(in) :: predicate integer :: int @@ -425,11 +463,13 @@ contains else int = 0 end if + end function f_logical_to_int !> Real spherical harmonic Y_lm(theta, phi). theta = polar angle from +z (acos(z/r)), phi = atan2(y,x). Uses associated Legendre !! P_l^|m|(cos theta). Standard normalisation. function real_ylm(theta, phi, l, m) result(Y) + integer, intent(in) :: l, m real(wp), intent(in) :: theta, phi real(wp) :: Y, x, prefac @@ -449,6 +489,7 @@ contains else Y = prefac*sqrt(2._wp)*associated_legendre(x, l, m_abs)*sin(m_abs*phi) end if + end function real_ylm !> Associated Legendre polynomial P_l^m(x) (Ferrers function, Condon-Shortley phase). Valid for integer l >= 0, 0 <= m <= l, and @@ -459,12 +500,14 @@ contains !! @param m_order order (0 <= m_order <= l) !! @return result_P P_l^m(x) recursive function associated_legendre(x, l, m_order) result(result_P) + integer, intent(in) :: l, m_order real(wp), intent(in) :: x real(wp) :: result_P real(wp) :: one_minus_x2 ! Out-of-domain: P_l^m = 0 for |m| > l or l < 0 (standard convention) + if (l < 0 .or. m_order < 0 .or. m_order > l) then result_P = 0._wp return @@ -485,32 +528,37 @@ contains result_P = x*(2*l - 1)*associated_legendre(x, l - 1, l - 1) else result_P = ((2*l - 1)*x*associated_legendre(x, l - 1, m_order) - (l + m_order - 1)*associated_legendre(x, l - 2, & - & m_order))/(l - m_order) + & m_order))/(l - m_order) end if + end function associated_legendre !> This function calculates the double factorial value of an integer !! @param n_in is the input integer !! @return R is the double factorial value of n elemental function double_factorial(n_in) result(R_result) + integer, intent(in) :: n_in integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer integer(kind=int64_kind) :: R_result integer :: i R_result = product((/(i, i=n_in, 1, -2)/)) + end function double_factorial !> The following function calculates the factorial value of an integer !! @param n_in is the input integer !! @return R is the factorial value of n elemental function factorial(n_in) result(R_result) + integer, intent(in) :: n_in integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer integer(kind=int64_kind) :: R_result integer :: i R_result = product((/(i, i=n_in, 1, -1)/)) + end function factorial !> This function calculates a smooth cut-on function that is zero for x values smaller than zero and goes to one. It can be used @@ -519,10 +567,12 @@ contains !! @param eps is the smoothing parameter !! @return fx is the cut-on function evaluated at x function f_cut_on(x, eps) result(fx) + real(wp), intent(in) :: x, eps real(wp) :: fx fx = 1 - f_gx(x/eps)/(f_gx(x/eps) + f_gx(1 - x/eps)) + end function f_cut_on !> This function calculates a smooth cut-off function that is one for x values smaller than zero and goes to zero. It can be @@ -531,16 +581,19 @@ contains !! @param eps is the smoothing parameter !! @return fx is the cut-ff function evaluated at x function f_cut_off(x, eps) result(fx) + real(wp), intent(in) :: x, eps real(wp) :: fx fx = f_gx(x/eps)/(f_gx(x/eps) + f_gx(1 - x/eps)) + end function f_cut_off !> This function is a helper function for the functions f_cut_on and f_cut_off !! @param x is the input value !! @return gx is the result function f_gx(x) result(gx) + real(wp), intent(in) :: x real(wp) :: gx @@ -549,10 +602,12 @@ contains else gx = 0._wp end if + end function f_gx !> @brief Downsamples conservative variable fields by a factor of 3 in each direction using volume averaging. subroutine s_downsample_data(q_cons_vf, q_cons_temp, m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_cons_temp ! Down sampling variables @@ -581,7 +636,7 @@ contains do iy = -1, 1 do ix = -1, 1 q_cons_temp(i)%sf(j, k, l) = q_cons_temp(i)%sf(j, k, & - & l) + (1._wp/27._wp)*q_cons_vf(i)%sf(x_id + ix, y_id + iy, z_id + iz) + & l) + (1._wp/27._wp)*q_cons_vf(i)%sf(x_id + ix, y_id + iy, z_id + iz) end do end do end do @@ -589,10 +644,12 @@ contains end do end do end do + end subroutine s_downsample_data !> @brief Upsamples conservative variable fields from a coarsened grid back to the original resolution using interpolation. subroutine s_upsample_data(q_cons_vf, q_cons_temp) + type(scalar_field), intent(inout), dimension(sys_size) :: q_cons_vf, q_cons_temp integer :: i, j, k, l integer :: ix, iy, iz @@ -613,13 +670,13 @@ contains temp(1) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy, iz) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy, iz) temp(2) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy + y_id, iz) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, & - & iy + y_id, iz) + & iy + y_id, iz) temp(3) = (2._wp/3._wp)*temp(1) + (1._wp/3._wp)*temp(2) temp(1) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy, iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, & - & iy, iz + z_id) + & iy, iz + z_id) temp(2) = (2._wp/3._wp)*q_cons_temp(i)%sf(ix, iy + y_id, & - & iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy + y_id, iz + z_id) + & iz + z_id) + (1._wp/3._wp)*q_cons_temp(i)%sf(ix + x_id, iy + y_id, iz + z_id) temp(4) = (2._wp/3._wp)*temp(1) + (1._wp/3._wp)*temp(2) q_cons_vf(i)%sf(j, k, l) = (2._wp/3._wp)*temp(3) + (1._wp/3._wp)*temp(4) @@ -627,5 +684,7 @@ contains end do end do end do + end subroutine s_upsample_data + end module m_helper diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 39aca7b7a5..299f5a9c69 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -6,12 +6,14 @@ !> @brief Basic floating-point utilities: approximate equality, default detection, and coordinate bounds module m_helper_basic + use m_derived_types !< Definitions of the derived types implicit none private; public :: f_approx_equal, f_approx_in_array, f_is_default, f_all_default, f_is_integer, s_configure_coordinate_bounds, & & s_update_cell_bounds + contains !> This procedure checks if two floating point numbers of wp are within tolerance. @@ -20,6 +22,7 @@ contains !! @param tol_input Relative error (default = 1.e-10_wp). !! @return Result of the comparison. logical elemental function f_approx_equal(a, b, tol_input) result(res) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: a, b real(wp), optional, intent(in) :: tol_input @@ -38,6 +41,7 @@ contains else res = (abs(a - b)/min(abs(a) + abs(b), huge(a)) < tol) end if + end function f_approx_equal !> This procedure checks if the point numbers of wp belongs to another array are within tolerance. @@ -46,6 +50,7 @@ contains !! @param tol_input Relative error (default = 1e-10_wp). !! @return Result of the comparison. logical function f_approx_in_array(a, b, tol_input) result(res) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: a real(wp), intent(in) :: b(:) @@ -67,44 +72,49 @@ contains exit end if end do + end function f_approx_in_array !> Checks if a real(wp) variable is of default value. !! @param var Variable to check. logical elemental function f_is_default(var) result(res) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: var res = f_approx_equal(var, dflt_real) + end function f_is_default !> Checks if ALL elements of a real(wp) array are of default value. !! @param var_array Array to check. logical function f_all_default(var_array) result(res) + real(wp), intent(in) :: var_array(:) res = all(f_is_default(var_array)) - ! logical :: res_array(size(var_array)) - ! integer :: i + ! logical :: res_array(size(var_array)) integer :: i - ! do i = 1, size(var_array) - ! res_array(i) = f_is_default(var_array(i)) - ! end do + ! do i = 1, size(var_array) res_array(i) = f_is_default(var_array(i)) end do ! res = all(res_array) + end function f_all_default !> Checks if a real(wp) variable is an integer. !! @param var Variable to check. logical elemental function f_is_integer(var) result(res) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: var res = f_approx_equal(var, real(nint(var), wp)) + end function f_is_integer subroutine s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & + & bubbles_lagrange, m, n, p, num_dims, igr, ib) integer, intent(in) :: recon_type, weno_polyn, muscl_polyn @@ -115,10 +125,9 @@ contains logical, intent(in) :: igr logical, intent(in) :: ib - ! Determining the number of cells that are needed in order to store - ! sufficient boundary conditions data as to iterate the solution in - ! the physical computational domain from one time-step iteration to - ! the next one + ! Determining the number of cells that are needed in order to store sufficient boundary conditions data as to iterate the + ! solution in the physical computational domain from one time-step iteration to the next one + if (igr) then buff_size = (igr_order - 1)/2 + 2 else if (recon_type == WENO_TYPE) then @@ -151,6 +160,7 @@ contains idwbuff(1)%end = idwint(1)%end - idwbuff(1)%beg idwbuff(2)%end = idwint(2)%end - idwbuff(2)%beg idwbuff(3)%end = idwint(3)%end - idwbuff(3)%beg + end subroutine s_configure_coordinate_bounds !> Updates the min and max number of cells in each set of axes @@ -159,6 +169,7 @@ contains !! @param n Number of cells in y-axis !! @param p Number of cells in z-axis elemental subroutine s_update_cell_bounds(bounds, m, n, p) + type(cell_num_bounds), intent(out) :: bounds integer, intent(in) :: m, n, p @@ -170,5 +181,7 @@ contains bounds%np_min = min(n, p) bounds%mp_min = min(m, p) bounds%mnp_min = min(m, n, p) + end subroutine s_update_cell_bounds + end module m_helper_basic diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index 40a46533e8..d6d467ee78 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -7,6 +7,7 @@ !> @brief Binary STL file reader and processor for immersed boundary geometry module m_model + use m_helper use m_mpi_proxy use m_derived_types @@ -38,12 +39,14 @@ module m_model integer, allocatable :: gpu_total_vertices(:) real(wp), allocatable :: stl_bounding_boxes(:,:,:) $:GPU_DECLARE(create='[gpu_ntrs, gpu_trs_v, gpu_trs_n, gpu_boundary_v, gpu_boundary_edge_count, gpu_total_vertices]') + contains !> This procedure reads a binary STL file. !! @param filepath Path to the STL file. !! @param model The binary of the STL file. impure subroutine s_read_stl_binary(filepath, model) + character(LEN=*), intent(in) :: filepath type(t_model), intent(out) :: model integer :: i, iunit, iostat @@ -82,12 +85,14 @@ contains end do close (iunit) + end subroutine s_read_stl_binary !> This procedure reads an ASCII STL file. !! @param filepath Path to the STL file. !! @param model the STL file. impure subroutine s_read_stl_ascii(filepath, model) + character(LEN=*), intent(in) :: filepath type(t_model), intent(out) :: model integer :: i, j, iunit, iostat @@ -190,12 +195,14 @@ contains i = i + 1 end do + end subroutine s_read_stl_ascii !> This procedure reads an STL file. !! @param filepath Path to the STL file. !! @param model the STL file. impure subroutine s_read_stl(filepath, model) + character(LEN=*), intent(in) :: filepath type(t_model), intent(out) :: model integer :: iunit, iostat @@ -218,12 +225,14 @@ contains else call s_read_stl_binary(filepath, model) end if + end subroutine s_read_stl !> This procedure reads an OBJ file. !! @param filepath Path to the obj file. !! @param model The obj file. impure subroutine s_read_obj(filepath, model) + character(LEN=*), intent(in) :: filepath type(t_model), intent(out) :: model integer :: i, j, k, l, iv3, iunit, iostat, nVertices @@ -287,12 +296,14 @@ contains deallocate (vertices) close (iunit) + end subroutine s_read_obj !> This procedure reads a mesh from a file. !! @param filepath Path to the file to read. !! @return The model read from the file. impure function f_model_read(filepath) result(model) + character(LEN=*), intent(in) :: filepath type(t_model) :: model @@ -306,12 +317,14 @@ contains call s_mpi_abort() end select + end function f_model_read !> This procedure writes a binary STL file. !! @param filepath Path to the STL file. !! @param model STL to write impure subroutine s_write_stl(filepath, model) + character(LEN=*), intent(in) :: filepath type(t_model), intent(in) :: model integer :: i, j, iunit, iostat @@ -351,12 +364,14 @@ contains end do close (iunit) + end subroutine s_write_stl !> This procedure writes an OBJ file. !! @param filepath Path to the obj file. !! @param model obj to write. impure subroutine s_write_obj(filepath, model) + character(LEN=*), intent(in) :: filepath type(t_model), intent(in) :: model integer :: iunit, iostat @@ -375,19 +390,21 @@ contains do i = 1, model%ntrs do j = 1, 3 write (iunit, '(A, " ", (f30.20), " ", (f30.20), " ", (f30.20))') "v", model%trs(i)%v(j, 1), model%trs(i)%v(j, & - & 2), model%trs(i)%v(j, 3) + & 2), model%trs(i)%v(j, 3) end do write (iunit, '(A, " ", I0, " ", I0, " ", I0)') "f", i*3 - 2, i*3 - 1, i*3 end do close (iunit) + end subroutine s_write_obj !> This procedure writes a binary STL file. !! @param filepath Path to the file to write. !! @param model Model to write. impure subroutine s_model_write(filepath, model) + character(LEN=*), intent(in) :: filepath type(t_model), intent(in) :: model @@ -401,16 +418,20 @@ contains call s_mpi_abort() end select + end subroutine s_model_write !> This procedure frees the memory allocated for an STL mesh. subroutine s_model_free(model) + type(t_model), intent(inout) :: model deallocate (model%trs) + end subroutine s_model_free impure function f_read_line(iunit, line) result(bIsLine) + integer, intent(in) :: iunit character(80), intent(out) :: line logical :: bIsLine @@ -434,10 +455,12 @@ contains exit end do + end function f_read_line !> @brief Reads the next non-comment line from a model file, using a buffered look-ahead mechanism. impure subroutine s_skip_ignored_lines(iunit, buffered_line, is_buffered) + integer, intent(in) :: iunit character(80), intent(inout) :: buffered_line logical, intent(inout) :: is_buffered @@ -452,11 +475,13 @@ contains buffered_line = line is_buffered = .true. + end subroutine s_skip_ignored_lines !> This function is used to replace the fortran random number generator because the native generator is not compatible being !! called from GPU routines/functions function f_model_random_number(seed) result(rval) + ! $:GPU_ROUTINE(parallelism='[seq]') integer, intent(inout) :: seed @@ -467,6 +492,7 @@ contains seed = ieor(seed, ishft(seed, 5)) rval = abs(real(seed, wp))/real(huge(seed), wp) + end function f_model_random_number !> This procedure, recursively, finds whether a point is inside an octree. @@ -476,6 +502,7 @@ contains !! @param spc Number of samples per cell. !! @return True if the point is inside the octree, false otherwise. impure function f_model_is_inside(model, point, spacing, spc) result(fraction) + ! $:GPU_ROUTINE(parallelism='[seq]') type(t_model), intent(in) :: model @@ -517,12 +544,12 @@ contains end if end do - ! if the ray hits an odd number of triangles on its way out, then - ! it must be on the inside of the model + ! if the ray hits an odd number of triangles on its way out, then it must be on the inside of the model nInOrOut = nInOrOut + mod(nHits, 2) end do fraction = real(nInOrOut)/real(spc) + end function f_model_is_inside !> This procedure determines if a point is inside a surface using the generalized winding number (Jacobson et al., SIGGRAPH @@ -534,6 +561,7 @@ contains !! @param point Point to test. !! @return fraction Winding number (~1.0 inside, ~0.0 outside). function f_model_is_inside_flat(ntrs, pid, point) result(fraction) + $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: ntrs @@ -549,8 +577,7 @@ contains fraction = 0.0_wp if (p == 0) then - ! 2D winding number: sum signed angles subtended by - ! each boundary edge at the query point. + ! 2D winding number: sum signed angles subtended by each boundary edge at the query point. do q = 1, gpu_boundary_edge_count(pid) d1(1) = gpu_boundary_v(q, 1, 1, pid) - point(1) d1(2) = gpu_boundary_v(q, 1, 2, pid) - point(2) @@ -564,8 +591,7 @@ contains ! 2D winding number = total angle / (2*pi) fraction = fraction/(2.0_wp*acos(-1.0_wp)) else - ! 3D winding number: sum solid angles via Van - ! Oosterom-Strackee formula. + ! 3D winding number: sum solid angles via Van Oosterom-Strackee formula. do q = 1, ntrs r1 = gpu_trs_v(1,:, q, pid) - point r2 = gpu_trs_v(2,:, q, pid) - point @@ -575,25 +601,23 @@ contains r2_mag = sqrt(dot_product(r2, r2)) r3_mag = sqrt(dot_product(r3, r3)) - ! Skip if query point is coincident with a vertex - ! (magnitudes are zero/subnormal). + ! Skip if query point is coincident with a vertex (magnitudes are zero/subnormal). if (r1_mag*r2_mag*r3_mag < tiny(1.0_wp)) cycle - ! tan(Omega/2) = numerator / denominator - ! numerator = scalar triple product r1 . (r2 x r3) + ! tan(Omega/2) = numerator / denominator numerator = scalar triple product r1 . (r2 x r3) numerator = r1(1)*(r2(2)*r3(3) - r2(3)*r3(2)) + r1(2)*(r2(3)*r3(1) - r2(1)*r3(3)) + r1(3)*(r2(1)*r3(2) - r2(2) & - & *r3(1)) + & *r3(1)) denominator = r1_mag*r2_mag*r3_mag + dot_product(r1, r2)*r3_mag + dot_product(r2, r3)*r1_mag + dot_product(r3, & - & r1)*r2_mag + & r1)*r2_mag fraction = fraction + atan2(numerator, denominator) end do - ! Each atan2 returns Omega/2 per triangle; divide - ! by 2*pi to get winding number = sum(Omega)/(4*pi). + ! Each atan2 returns Omega/2 per triangle; divide by 2*pi to get winding number = sum(Omega)/(4*pi). fraction = fraction/(2.0_wp*acos(-1.0_wp)) end if + end function f_model_is_inside_flat !> This procedure checks if a ray intersects a triangle using the Moller-Trumbore algorithm (barycentric coordinates). Unlike @@ -602,6 +626,7 @@ contains !! @param triangle Triangle. !! @return 1 if the ray intersects the triangle, 0 otherwise. function f_intersects_triangle(ray, triangle) result(intersects) + $:GPU_ROUTINE(parallelism='[seq]') type(t_ray), intent(in) :: ray @@ -617,8 +642,7 @@ contains h = f_cross(ray%d, edge2) a = dot_product(edge1, h) - ! Ray nearly parallel to triangle plane. In single precision - ! builds epsilon(1.0) ~ 1.2e-7, so use 10*epsilon as a floor. + ! Ray nearly parallel to triangle plane. In single precision builds epsilon(1.0) ~ 1.2e-7, so use 10*epsilon as a floor. if (abs(a) < max(1e-7_wp, 10.0_wp*epsilon(1.0_wp))) return f = 1.0_wp/a @@ -635,23 +659,26 @@ contains t = f*dot_product(edge2, q) if (t > 0.0_wp) intersects = 1 + end function f_intersects_triangle !> This procedure checks and labels edges shared by two or more triangles facets of the 2D STL model. !! @param model Model to search in. !! @param boundary_vertex_count Output total boundary vertex count subroutine s_check_boundary(model, boundary_v, boundary_vertex_count, boundary_edge_count) - type(t_model), intent(in) :: model + + type(t_model), intent(in) :: model real(wp), allocatable, intent(out), dimension(:,:,:) :: boundary_v !< Output boundary vertices/normals - integer, intent(out) :: boundary_vertex_count, boundary_edge_count !< Output boundary vertex/edge count - integer :: i, j !< Model index iterator - integer :: edge_count, edge_index, store_index !< Boundary edge index iterator - real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer - real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer - real(wp), dimension(1:(3*model%ntrs), 1:2, 1:2) :: temp_boundary_v !< Temporary boundary vertex buffer - integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges - real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges + integer, intent(out) :: boundary_vertex_count, boundary_edge_count !< Output boundary vertex/edge count + integer :: i, j !< Model index iterator + integer :: edge_count, edge_index, store_index !< Boundary edge index iterator + real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer + real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer + real(wp), dimension(1:(3*model%ntrs), 1:2, 1:2) :: temp_boundary_v !< Temporary boundary vertex buffer + integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges + real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges ! Total number of edges in 2D STL + edge_count = 3*model%ntrs ! Initialize edge_occurrence array to zero @@ -746,18 +773,22 @@ contains boundary_v(i, 3, 1) = xnormal/v_norm boundary_v(i, 3, 2) = ynormal/v_norm end do + end subroutine s_check_boundary !> This procedure appends the edge end vertices to a temporary buffer. subroutine s_register_edge(temp_boundary_v, edge, edge_index, edge_count) + integer, intent(inout) :: edge_index !< Edge index iterator integer, intent(inout) :: edge_count !< Total number of edges real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered real(wp), dimension(1:edge_count, 1:2, 1:2), intent(inout) :: temp_boundary_v !< Temporary edge end vertex buffer ! Increment edge index and store the edge + edge_index = edge_index + 1 temp_boundary_v(edge_index, 1, 1:2) = edge(1, 1:2) temp_boundary_v(edge_index, 2, 1:2) = edge(2, 1:2) + end subroutine s_register_edge !> This procedure determines the levelset distance and normals of 3D models by computing the exact closest point via projection @@ -770,6 +801,7 @@ contains !! @param normals Output levelset normals !! @param distance Output levelset distance subroutine s_distance_normals_3D(ntrs, pid, point, normals, distance) + $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: ntrs @@ -878,7 +910,7 @@ contains end if else dist_v = sqrt((point(1) - verts(1, mod(j, 3) + 1))**2 + (point(2) - verts(2, mod(j, & - & 3) + 1))**2 + (point(3) - verts(3, mod(j, 3) + 1))**2) + & 3) + 1))**2 + (point(3) - verts(3, mod(j, 3) + 1))**2) if (dist_v < dist_min) then dist_min = dist_v @@ -893,6 +925,7 @@ contains end do distance = dist_min + end subroutine s_distance_normals_3D !> This procedure determines the levelset distance and normals of 2D models by computing the exact closest point via projection @@ -904,6 +937,7 @@ contains !! @param normals Output levelset normals !! @param distance Output levelset distance subroutine s_distance_normals_2D(pid, boundary_edge_count, point, normals, distance) + $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: pid @@ -966,11 +1000,13 @@ contains end do distance = dist_min + end subroutine s_distance_normals_2D #ifdef MFC_SIMULATION subroutine s_instantiate_STL_models() + ! Variables for IBM+STL real(wp) :: normals(1:3) !< Boundary normal buffer integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex @@ -1117,7 +1153,7 @@ contains end if if (allocated(models(pid)%boundary_v) .and. p == 0) then gpu_boundary_v(1:size(models(pid)%boundary_v, 1), 1:size(models(pid)%boundary_v, 2), & - & 1:size(models(pid)%boundary_v, 3), pid) = models(pid)%boundary_v + & 1:size(models(pid)%boundary_v, 3), pid) = models(pid)%boundary_v end if end do @@ -1127,11 +1163,12 @@ contains end if end if end block - end subroutine s_instantiate_STL_models + end subroutine s_instantiate_STL_models #endif subroutine s_pack_model_for_gpu(ma) + type(t_model_array), intent(inout) :: ma integer :: i @@ -1143,5 +1180,7 @@ contains ma%trs_v(:,:, i) = ma%model%trs(i)%v(:,:) ma%trs_n(:, i) = ma%model%trs(i)%n(:) end do + end subroutine s_pack_model_for_gpu + end module m_model diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 0caece3da4..0f0b1f971e 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -7,11 +7,12 @@ !> @brief MPI communication layer: domain decomposition, halo exchange, reductions, and parallel I/O setup module m_mpi_common + #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_helper use ieee_arithmetic @@ -35,15 +36,16 @@ module m_mpi_common integer(kind=8) :: halo_size $:GPU_DECLARE(create='[halo_size]') + contains !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_mpi_common_module + #ifdef MFC_MPI - ! Allocating buff_send/recv and. Please note that for the sake of - ! simplicity, both variables are provided sufficient storage to hold - ! the largest buffer in the computational domain. + ! Allocating buff_send/recv and. Please note that for the sake of simplicity, both variables are provided sufficient storage + ! to hold the largest buffer in the computational domain. if (qbmm .and. .not. polytropic) then v_size = sys_size + 2*nb*nnode @@ -54,7 +56,7 @@ contains if (n > 0) then if (p > 0) then halo_size = nint(-1._wp + 1._wp*buff_size*(v_size)*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)*(p + 2*buff_size & - & + 1)/(cells_bounds%mnp_min + 2*buff_size + 1)) + & + 1)/(cells_bounds%mnp_min + 2*buff_size + 1)) else halo_size = -1 + buff_size*(v_size)*(cells_bounds%mn_max + 2*buff_size + 1) end if @@ -72,14 +74,17 @@ contains $:GPU_ENTER_DATA(create='[capture:buff_recv]') #endif #endif + end subroutine s_initialize_mpi_common_module !> The subroutine initializes the MPI execution environment and queries both the number of processors which will be available !! for the job and the local processor rank. impure subroutine s_mpi_initialize + #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Initializing the MPI environment + call MPI_INIT(ierr) ! Checking whether the MPI environment has been properly initialized @@ -99,12 +104,14 @@ contains ! Local processor rank is 0 proc_rank = 0 #endif + end subroutine s_mpi_initialize !! @param q_cons_vf Conservative variables !! @param ib_markers track if a cell is within the immersed boundary !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_initialize_mpi_data(q_cons_vf, ib_markers, beta) + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(integer_field), optional, intent(in) :: ib_markers type(scalar_field), intent(in), optional :: beta @@ -160,7 +167,7 @@ contains ! Define the view for each variable do i = 1, alt_sys call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do @@ -168,7 +175,7 @@ contains if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do end if @@ -179,15 +186,17 @@ contains MPI_IO_IB_DATA%var%sf => ib_markers%sf(0:m, 0:n, 0:p) call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, MPI_INTEGER, & - & MPI_IO_IB_DATA%view, ierr) + & MPI_IO_IB_DATA%view, ierr) call MPI_TYPE_COMMIT(MPI_IO_IB_DATA%view, ierr) end if #endif #endif + end subroutine s_initialize_mpi_data !! @param q_cons_vf Conservative variables subroutine s_initialize_mpi_data_ds(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf integer, dimension(num_dims) :: sizes_glb, sizes_loc integer, dimension(3) :: sf_start_idx @@ -226,14 +235,16 @@ contains ! Define the view for each variable do i = 1, sys_size call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_loc, sizes_loc, sf_start_idx, MPI_ORDER_FORTRAN, mpi_p, & - & MPI_IO_DATA%view(i), ierr) + & MPI_IO_DATA%view(i), ierr) call MPI_TYPE_COMMIT(MPI_IO_DATA%view(i), ierr) end do #endif + end subroutine s_initialize_mpi_data_ds !> @brief Gathers variable-length real vectors from all MPI ranks onto the root process. impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root) + integer, intent(in) :: counts ! Array of vector lengths for each process real(wp), intent(in), dimension(counts) :: my_vector ! Input vector on each process integer, intent(in) :: root ! Rank of the root process @@ -259,21 +270,26 @@ contains allocate (gathered_vector(sum(recounts))) call MPI_GATHERV(my_vector, counts, mpi_p, gathered_vector, recounts, displs, mpi_p, root, MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_gather_data !> @brief Gathers per-rank time step wall-clock times onto rank 0 for performance reporting. impure subroutine mpi_bcast_time_step_values(proc_time, time_avg) + real(wp), dimension(0:num_procs - 1), intent(inout) :: proc_time real(wp), intent(inout) :: time_avg #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors + call MPI_GATHER(time_avg, 1, mpi_p, proc_time(0), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif + end subroutine mpi_bcast_time_step_values !> @brief Prints a case file error with the prohibited condition and message, then aborts execution. impure subroutine s_prohibit_abort(condition, message) + character(len=*), intent(in) :: condition, message print *, "" @@ -284,6 +300,7 @@ contains end if print *, "" call s_mpi_abort(code=CASE_FILE_ERROR_CODE) + end subroutine s_prohibit_abort !> The goal of this subroutine is to determine the global extrema of the stability criteria in the computational domain. This is @@ -297,6 +314,7 @@ contains !! @param vcfl_max_glb Global maximum VCFL stability criterion !! @param Rc_min_glb Global minimum Rc stability criterion impure subroutine s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & + & Rc_min_glb) real(wp), intent(in) :: icfl_max_loc @@ -309,8 +327,9 @@ contains #ifdef MFC_SIMULATION #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Reducing local extrema of ICFL, VCFL, CCFL and Rc numbers to their - ! global extrema and bookkeeping the results on the rank 0 processor + ! Reducing local extrema of ICFL, VCFL, CCFL and Rc numbers to their global extrema and bookkeeping the results on the rank + ! 0 processor + call MPI_REDUCE(icfl_max_loc, icfl_max_glb, 1, mpi_p, MPI_MAX, 0, MPI_COMM_WORLD, ierr) if (viscous) then @@ -327,6 +346,7 @@ contains end if #endif #endif + end subroutine s_mpi_reduce_stability_criteria_extrema !> The following subroutine takes the input local variable from all processors and reduces to the sum of all values. The reduced @@ -335,19 +355,23 @@ contains ! communicator. !! @param var_glb The globally reduced value impure subroutine s_mpi_allreduce_sum(var_loc, var_glb) + real(wp), intent(in) :: var_loc real(wp), intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_allreduce_sum !> This subroutine follows the behavior of the s_mpi_allreduce_sum subroutine !> with the additional feature that it reduces an array of vectors. impure subroutine s_mpi_allreduce_vectors_sum(var_loc, var_glb, num_vectors, vector_length) + integer, intent(in) :: num_vectors, vector_length real(wp), dimension(:,:), intent(in) :: var_loc real(wp), dimension(:,:), intent(out) :: var_glb @@ -355,6 +379,7 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure + if (loc(var_loc) == loc(var_glb)) then call MPI_Allreduce(MPI_IN_PLACE, var_glb, num_vectors*vector_length, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) else @@ -363,6 +388,7 @@ contains #else var_glb(1:num_vectors, 1:vector_length) = var_loc(1:num_vectors, 1:vector_length) #endif + end subroutine s_mpi_allreduce_vectors_sum !> The following subroutine takes the input local variable from all processors and reduces to the sum of all values. The reduced @@ -371,16 +397,19 @@ contains ! communicator. !! @param var_glb The globally reduced value impure subroutine s_mpi_allreduce_integer_sum(var_loc, var_glb) + integer, intent(in) :: var_loc integer, intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure + call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) #else var_glb = var_loc #endif + end subroutine s_mpi_allreduce_integer_sum !> The following subroutine takes the input local variable from all processors and reduces to the minimum of all values. The @@ -389,14 +418,17 @@ contains ! communicator. !! @param var_glb The globally reduced value impure subroutine s_mpi_allreduce_min(var_loc, var_glb) + real(wp), intent(in) :: var_loc real(wp), intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_allreduce_min !> The following subroutine takes the input local variable from all processors and reduces to the maximum of all values. The @@ -405,14 +437,17 @@ contains ! communicator. !! @param var_glb The globally reduced value impure subroutine s_mpi_allreduce_max(var_loc, var_glb) + real(wp), intent(in) :: var_loc real(wp), intent(out) :: var_glb #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Performing the reduction procedure + call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MAX, MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_allreduce_max !> The following subroutine takes the inputted variable and determines its minimum value on the entire computational domain. The @@ -420,6 +455,7 @@ contains ! ! @param var_loc holds the local value to be reduced among all the processors in communicator. On output, the variable holds ! the minimum value, reduced amongst all of the local values. impure subroutine s_mpi_reduce_min(var_loc) + real(wp), intent(inout) :: var_loc #ifdef MFC_MPI @@ -427,14 +463,16 @@ contains ! Temporary storage variable that holds the reduced minimum value real(wp) :: var_glb - ! Performing reduction procedure and eventually storing its result - ! into the variable that was initially inputted into the subroutine + ! Performing reduction procedure and eventually storing its result into the variable that was initially inputted into the + ! subroutine + call MPI_REDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(var_glb, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) var_loc = var_glb #endif + end subroutine s_mpi_reduce_min !> The following subroutine takes the first element of the 2-element inputted variable and determines its maximum value on the @@ -444,6 +482,7 @@ contains ! processors in communicator. On output, this variable holds the maximum value, reduced amongst all of the local values, and the ! process rank to which the value belongs. impure subroutine s_mpi_reduce_maxloc(var_loc) + real(wp), dimension(2), intent(inout) :: var_loc #ifdef MFC_MPI @@ -451,20 +490,23 @@ contains !> Temporary storage variable that holds the reduced maximum value and the rank of the processor with which the value is !! associated real(wp), dimension(2) :: var_glb - ! Performing reduction procedure and eventually storing its result - ! into the variable that was initially inputted into the subroutine + ! Performing reduction procedure and eventually storing its result into the variable that was initially inputted into the + ! subroutine + call MPI_REDUCE(var_loc, var_glb, 1, mpi_2p, MPI_MAXLOC, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(var_glb, 1, mpi_2p, 0, MPI_COMM_WORLD, ierr) var_loc = var_glb #endif + end subroutine s_mpi_reduce_maxloc !> The subroutine terminates the MPI execution environment. - !! @param prnt error message to be printed - !! @param code optional exit code + !! @param prnt error message to be printed + !! @param code optional exit code impure subroutine s_mpi_abort(prnt, code) + character(len=*), intent(in), optional :: prnt integer, intent(in), optional :: code @@ -491,24 +533,31 @@ contains call MPI_ABORT(MPI_COMM_WORLD, 1, ierr) end if #endif + end subroutine s_mpi_abort !> Halts all processes until all have reached barrier. impure subroutine s_mpi_barrier + #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Calling MPI_BARRIER + call MPI_BARRIER(MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_barrier !> The subroutine finalizes the MPI execution environment. impure subroutine s_mpi_finalize + #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Finalizing the MPI environment + call MPI_FINALIZE(ierr) #endif + end subroutine s_mpi_finalize !> The goal of this procedure is to populate the buffers of the cell-average conservative variables by communicating with the @@ -520,19 +569,21 @@ contains !! @param pb_in Optional internal bubble pressure !! @param mv_in Optional bubble mass velocity subroutine s_mpi_sendrecv_variables_buffers(q_comm, mpi_dir, pbc_loc, nVar, pb_in, mv_in) - type(scalar_field), dimension(1:), intent(inout) :: q_comm + + type(scalar_field), dimension(1:), intent(inout) :: q_comm real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: mpi_dir, pbc_loc, nVar - integer :: i, j, k, l, r, q !< Generic loop iterators - integer :: buffer_counts(1:3), buffer_count - type(int_bounds_info) :: boundary_conditions(1:3) - integer :: beg_end(1:2), grid_dims(1:3) - integer :: dst_proc, src_proc, recv_tag, send_tag - logical :: beg_end_geq_0, qbmm_comm - integer :: pack_offset, unpack_offset + integer, intent(in) :: mpi_dir, pbc_loc, nVar + integer :: i, j, k, l, r, q !< Generic loop iterators + integer :: buffer_counts(1:3), buffer_count + type(int_bounds_info) :: boundary_conditions(1:3) + integer :: beg_end(1:2), grid_dims(1:3) + integer :: dst_proc, src_proc, recv_tag, send_tag + logical :: beg_end_geq_0, qbmm_comm + integer :: pack_offset, unpack_offset #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors + call nvtxStartRange("RHS-COMM-PACKBUF") qbmm_comm = .false. @@ -541,11 +592,11 @@ contains qbmm_comm = .true. v_size = nVar + 2*nb*nnode buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), & - & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) + & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) else v_size = nVar buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), & - & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) + & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/) end if $:GPU_UPDATE(device='[v_size]') @@ -555,12 +606,9 @@ contains beg_end = (/boundary_conditions(mpi_dir)%beg, boundary_conditions(mpi_dir)%end/) beg_end_geq_0 = beg_end(max(pbc_loc, 0) - pbc_loc + 1) >= 0 - ! Implements: - ! pbc_loc bc_x >= 0 -> [send/recv]_tag [dst/src]_proc - ! -1 (=0) 0 -> [1,0] [0,0] | 0 0 [1,0] [beg,beg] - ! -1 (=0) 1 -> [0,0] [1,0] | 0 1 [0,0] [end,beg] - ! +1 (=1) 0 -> [0,1] [1,1] | 1 0 [0,1] [end,end] - ! +1 (=1) 1 -> [1,1] [0,1] | 1 1 [1,1] [beg,end] + ! Implements: pbc_loc bc_x >= 0 -> [send/recv]_tag [dst/src]_proc -1 (=0) 0 -> [1,0] [0,0] | 0 0 [1,0] [beg,beg] -1 (=0) 1 + ! -> [0,0] [1,0] | 0 1 [0,0] [end,beg] +1 (=1) 0 -> [0,1] [1,1] | 1 0 [0,1] [end,end] +1 (=1) 1 -> [1,1] [0,1] | 1 1 [1,1] + ! [beg,end] send_tag = f_logical_to_int(.not. f_xor(beg_end_geq_0, pbc_loc == 1)) recv_tag = f_logical_to_int(pbc_loc == 1) @@ -650,7 +698,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*(k & - & + buff_size*l)) + & + buff_size*l)) buff_send(r) = real(pb_in(j, k + pack_offset, l, i - nVar, q), kind=wp) end do end do @@ -666,7 +714,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & - & + 1)*(k + buff_size*l)) + & + 1)*(k + buff_size*l)) buff_send(r) = real(mv_in(j, k + pack_offset, l, i - nVar, q), kind=wp) end do end do @@ -682,7 +730,7 @@ contains do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n & - & + 2*buff_size + 1)*l)) + & + 2*buff_size + 1)*l)) buff_send(r) = real(q_comm(i)%sf(j, k, l + pack_offset), kind=wp) end do end do @@ -698,7 +746,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & - & + buff_size) + (n + 2*buff_size + 1)*l)) + & + buff_size) + (n + 2*buff_size + 1)*l)) buff_send(r) = real(pb_in(j, k, l + pack_offset, i - nVar, q), kind=wp) end do end do @@ -714,7 +762,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & - & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*l)) + & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*l)) buff_send(r) = real(mv_in(j, k, l + pack_offset, i - nVar, q), kind=wp) end do end do @@ -737,7 +785,7 @@ contains call nvtxStartRange("RHS-COMM-SENDRECV-RDMA") call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, & - & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA #:endcall GPU_HOST_DATA @@ -749,7 +797,7 @@ contains call nvtxStartRange("RHS-COMM-SENDRECV-NO-RMDA") call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, & - & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA @@ -761,7 +809,7 @@ contains #:endfor #else call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, src_proc, recv_tag, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) #endif ! Unpack Received Buffer @@ -847,7 +895,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & - & + buff_size) + buff_size*l)) + & + buff_size) + buff_size*l)) pb_in(j, k + unpack_offset, l, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -863,7 +911,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & - & + 1)*((k + buff_size) + buff_size*l)) + & + 1)*((k + buff_size) + buff_size*l)) mv_in(j, k + unpack_offset, l, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -880,7 +928,7 @@ contains do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n & - & + 2*buff_size + 1)*(l + buff_size))) + & + 2*buff_size + 1)*(l + buff_size))) q_comm(i)%sf(j, k, l + unpack_offset) = real(buff_recv(r), kind=stp) #if defined(__INTEL_COMPILER) if (ieee_is_nan(q_comm(i)%sf(j, k, l + unpack_offset))) then @@ -902,7 +950,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k & - & + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) + & + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) pb_in(j, k, l + unpack_offset, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -918,7 +966,7 @@ contains do j = -buff_size, m + buff_size do q = 1, nb r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size & - & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) + & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*(l + buff_size))) mv_in(j, k, l + unpack_offset, i - nVar, q) = real(buff_recv(r), kind=stp) end do end do @@ -932,12 +980,14 @@ contains #:endfor call nvtxEndRange #endif + end subroutine s_mpi_sendrecv_variables_buffers !> The purpose of this procedure is to optimally decompose the computational domain among the available processors. This is !! performed by attempting to award each processor, in each of the coordinate directions, approximately the same number of !! cells, and then recomputing the affected global parameters. subroutine s_mpi_decompose_computational_domain + #ifdef MFC_MPI integer :: num_procs_x, num_procs_y, num_procs_z !< Optimal number of processors in the x-, y- and z-directions @@ -951,6 +1001,7 @@ contains integer :: recon_order !< WENO or MUSCL reconstruction order integer :: i, j !< Generic loop iterators integer :: ierr !< Generic flag used to identify and report MPI errors + if (recon_type == WENO_TYPE) then recon_order = weno_order else @@ -1001,9 +1052,9 @@ contains else if (cyl_coord .and. p > 0) then - ! Implement pencil processor blocking if using cylindrical coordinates so - ! that all cells in azimuthal direction are stored on a single processor. - ! This is necessary for efficient application of Fourier filter near axis. + ! Implement pencil processor blocking if using cylindrical coordinates so that all cells in azimuthal + ! direction are stored on a single processor. This is necessary for efficient application of Fourier filter + ! near axis. ! Initial values of the processor factorization optimization num_procs_x = 1 @@ -1045,7 +1096,7 @@ contains tmp_num_procs_y = num_procs_y tmp_num_procs_z = num_procs_z fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + 10._wp*abs((n + 1) & - & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) + & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) ! Optimization of the initial processor topology do i = 1, num_procs @@ -1063,7 +1114,7 @@ contains num_procs_y = j num_procs_z = num_procs/(i*j) fct_min = abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + abs((n + 1) & - & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) + & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) ierr = 0 end if end if @@ -1073,16 +1124,16 @@ contains end if end if - ! Verifying that a valid decomposition of the computational - ! domain has been established. If not, the simulation exits. + ! Verifying that a valid decomposition of the computational domain has been established. If not, the simulation + ! exits. if (proc_rank == 0 .and. ierr == -1) then call s_mpi_abort('Unsupported combination of values ' // 'of num_procs, m, n, p and ' & - & // 'weno/muscl/igr_order. Exiting.') + & // 'weno/muscl/igr_order. Exiting.') end if ! Creating new communicator using the Cartesian topology call MPI_CART_CREATE(MPI_COMM_WORLD, 3, (/num_procs_x, num_procs_y, num_procs_z/), (/.true., .true., .true./), & - & .false., MPI_COMM_CART, ierr) + & .false., MPI_COMM_CART, ierr) ! Finding the Cartesian coordinates of the local process call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, proc_coords, ierr) @@ -1148,7 +1199,7 @@ contains if (proc_coords(3) < rem_cells) then z_domain%beg = z_domain%beg + dz*real((p + 1)*proc_coords(3)) z_domain%end = z_domain%end - dz*real((p + 1)*(num_procs_z - proc_coords(3) - 1) - (num_procs_z & - & - rem_cells)) + & - rem_cells)) else z_domain%beg = z_domain%beg + dz*real((p + 1)*proc_coords(3) + rem_cells) z_domain%end = z_domain%end - dz*real((p + 1)*(num_procs_z - proc_coords(3) - 1)) @@ -1186,16 +1237,16 @@ contains end if end do - ! Verifying that a valid decomposition of the computational - ! domain has been established. If not, the simulation exits. + ! Verifying that a valid decomposition of the computational domain has been established. If not, the simulation + ! exits. if (proc_rank == 0 .and. ierr == -1) then call s_mpi_abort('Unsupported combination of values ' // 'of num_procs, m, n and ' & - & // 'weno/muscl/igr_order. Exiting.') + & // 'weno/muscl/igr_order. Exiting.') end if ! Creating new communicator using the Cartesian topology call MPI_CART_CREATE(MPI_COMM_WORLD, 2, (/num_procs_x, num_procs_y/), (/.true., .true./), .false., MPI_COMM_CART, & - & ierr) + & ierr) ! Finding the Cartesian coordinates of the local process call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 2, proc_coords, ierr) @@ -1262,7 +1313,7 @@ contains if (proc_coords(2) < rem_cells) then y_domain%beg = y_domain%beg + dy*real((n + 1)*proc_coords(2)) y_domain%end = y_domain%end - dy*real((n + 1)*(num_procs_y - proc_coords(2) - 1) - (num_procs_y & - & - rem_cells)) + & - rem_cells)) else y_domain%beg = y_domain%beg + dy*real((n + 1)*proc_coords(2) + rem_cells) y_domain%end = y_domain%end - dy*real((n + 1)*(num_procs_y - proc_coords(2) - 1)) @@ -1354,6 +1405,7 @@ contains #endif end if #endif + end subroutine s_mpi_decompose_computational_domain !> The goal of this procedure is to populate the buffers of the grid variables by communicating with the neighboring processors. @@ -1363,12 +1415,14 @@ contains !! @param pbc_loc Processor boundary condition (PBC) location #ifndef MFC_PRE_PROCESS subroutine s_mpi_sendrecv_grid_variables_buffers(mpi_dir, pbc_loc) + integer, intent(in) :: mpi_dir integer, intent(in) :: pbc_loc #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! MPI Communication in x-direction + if (mpi_dir == 1) then if (pbc_loc == -1) then ! PBC at the beginning @@ -1376,12 +1430,12 @@ contains ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(-buff_size), buff_size, mpi_p, & - & bc_x%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_x%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only ! Send/receive buffer to/from bc_x%beg/bc_x%beg call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(-buff_size), buff_size, mpi_p, bc_x%beg, 0, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end @@ -1389,12 +1443,12 @@ contains ! Send/receive buffer to/from bc_x%beg/bc_x%end call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(m + 1), buff_size, mpi_p, bc_x%end, 1, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only ! Send/receive buffer to/from bc_x%end/bc_x%end call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(m + 1), buff_size, mpi_p, & - & bc_x%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_x%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if ! END: MPI Communication in x-direction @@ -1407,12 +1461,12 @@ contains ! Send/receive buffer to/from bc_y%end/bc_y%beg call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(-buff_size), buff_size, mpi_p, & - & bc_y%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_y%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only ! Send/receive buffer to/from bc_y%beg/bc_y%beg call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(-buff_size), buff_size, mpi_p, bc_y%beg, 0, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end @@ -1420,12 +1474,12 @@ contains ! Send/receive buffer to/from bc_y%beg/bc_y%end call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(n + 1), buff_size, mpi_p, bc_y%end, 1, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only ! Send/receive buffer to/from bc_y%end/bc_y%end call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(n + 1), buff_size, mpi_p, & - & bc_y%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_y%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if ! END: MPI Communication in y-direction @@ -1439,12 +1493,12 @@ contains ! Send/receive buffer to/from bc_z%end/bc_z%beg call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(-buff_size), buff_size, mpi_p, & - & bc_z%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_z%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only ! Send/receive buffer to/from bc_z%beg/bc_z%beg call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(-buff_size), buff_size, mpi_p, bc_z%beg, 0, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end @@ -1452,25 +1506,28 @@ contains ! Send/receive buffer to/from bc_z%beg/bc_z%end call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(p + 1), buff_size, mpi_p, bc_z%end, 1, & - & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only ! Send/receive buffer to/from bc_z%end/bc_z%end call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(p + 1), buff_size, mpi_p, & - & bc_z%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) + & bc_z%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if end if ! END: MPI Communication in z-direction #endif - end subroutine s_mpi_sendrecv_grid_variables_buffers + end subroutine s_mpi_sendrecv_grid_variables_buffers #endif !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_mpi_common_module + #ifdef MFC_MPI deallocate (buff_send, buff_recv) #endif + end subroutine s_finalize_mpi_common_module + end module m_mpi_common diff --git a/src/common/m_nvtx.f90 b/src/common/m_nvtx.f90 index 6707bc0d5f..b6c0d64f40 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -4,12 +4,13 @@ !> @brief NVIDIA NVTX profiling API bindings for GPU performance instrumentation module m_nvtx + use iso_c_binding implicit none integer, private :: col(7) = [int(Z'0000ff00'), int(Z'000000ff'), int(Z'00ffff00'), int(Z'00ff00ff'), int(Z'0000ffff'), & - & int(Z'00ff0000'), int(Z'00ffffff')] + & int(Z'00ff0000'), int(Z'00ffffff')] character(len=256), private :: tempName @@ -31,28 +32,35 @@ module m_nvtx interface nvtxRangePush ! push range with custom label and standard color subroutine nvtxRangePushA(name) bind(C, name='nvtxRangePushA') + use iso_c_binding character(kind=c_char, len=*), intent(in) :: name + end subroutine nvtxRangePushA ! push range with custom label and custom color subroutine nvtxRangePushEx(event) bind(C, name='nvtxRangePushEx') + use iso_c_binding import :: nvtxEventAttributes type(nvtxEventAttributes), intent(in) :: event + end subroutine nvtxRangePushEx end interface nvtxRangePush interface nvtxRangePop subroutine nvtxRangePop() bind(C, name='nvtxRangePop') + end subroutine nvtxRangePop end interface nvtxRangePop #endif + contains !> @brief Pushes a named NVTX range for GPU profiling, optionally with a color based on the given identifier. subroutine nvtxStartRange(name, id) + character(kind=c_char, len=*), intent(in) :: name integer, intent(in), optional :: id type(nvtxEventAttributes) :: event @@ -69,12 +77,16 @@ subroutine nvtxStartRange(name, id) call nvtxRangePushEx(event) end if #endif + end subroutine nvtxStartRange !> @brief Pops the current NVTX range to end the GPU profiling region. subroutine nvtxEndRange + #if defined(MFC_GPU) && defined(__PGI) call nvtxRangePop #endif + end subroutine nvtxEndRange + end module m_nvtx diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index c8bd4fe20c..d87c7810f3 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -7,14 +7,15 @@ !> @brief Phase transition relaxation solvers for liquid-vapor flows with cavitation and boiling module m_phase_change + #ifndef MFC_POST_PROCESS - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures use ieee_arithmetic - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers implicit none private; @@ -36,20 +37,24 @@ module m_phase_change !> @} $:GPU_DECLARE(create='[A, B, C, D]') + contains !> This subroutine should dispatch to the correct relaxation solver based some parameter. It replaces the procedure pointer, !! which CCE is breaking on. impure subroutine s_relaxation_solver(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - ! This is empty because in current master the procedure pointer - ! was never assigned + ! This is empty because in current master the procedure pointer was never assigned + @:ASSERT(.false., "s_relaxation_solver called but it currently does nothing") + end subroutine s_relaxation_solver !> The purpose of this subroutine is to initialize the phase change module by setting the parameters needed for phase change and !! selecting the phase change module that will be used (pT- or pTg-equilibrium) impure subroutine s_initialize_phasechange_module + ! variables used in the calculation of the saturation curves for fluids 1 and 2 A = (gs_min(lp)*cvs(lp) - gs_min(vp)*cvs(vp) + qvps(vp) - qvps(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) @@ -58,14 +63,16 @@ contains C = (gs_min(vp)*cvs(vp) - gs_min(lp)*cvs(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) D = ((gs_min(lp) - 1.0_wp)*cvs(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) + end subroutine s_initialize_phasechange_module !> This subroutine is created to activate either the pT- (N fluids) or the pTg-equilibrium (2 fluids for g-equilibrium) model, !! also considering mass depletion, depending on the incoming state conditions. !! @param q_cons_vf Cell-average conservative variables subroutine s_infinite_relaxation_k(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid + real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid !> equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor !! and subcooled liquid real(wp) :: TS, TSOV, TSSL, TSatOV, TSatSL @@ -81,22 +88,20 @@ contains #:endif ! $:GPU_DECLARE(create='[p_infOV,p_infpT,p_infSL,sk,hk,gk,ek,rhok]') - !< Generic loop iterators + !> Generic loop iterators integer :: i, j, k, l #ifdef _CRAYFTN #ifdef MFC_OpenACC - ! CCE 19 IPA workaround: prevent bring_routine_resident SIGSEGV - ! DIR$ NOINLINE s_infinite_pt_relaxation_k - ! DIR$ NOINLINE s_infinite_ptg_relaxation_k - ! DIR$ NOINLINE s_correct_partial_densities - ! DIR$ NOINLINE s_TSat + ! CCE 19 IPA workaround: prevent bring_routine_resident SIGSEGV DIR$ NOINLINE s_infinite_pt_relaxation_k DIR$ NOINLINE + ! s_infinite_ptg_relaxation_k DIR$ NOINLINE s_correct_partial_densities DIR$ NOINLINE s_TSat #endif #endif ! starting equilibrium solver + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok, pS, pSOV, pSSL, TS, & - & TSOV, TSatOV, TSatSL, TSSL, rhoe, dynE, rhos, rho, rM, m1, m2, MCT, TvF]') + & TSOV, TSatOV, TSatSL, TSSL, rhoe, dynE, rhos, rho, rM, m1, m2, MCT, TvF]') do j = 0, m do k = 0, n do l = 0, p @@ -130,27 +135,25 @@ contains dynE = dynE + 5.0e-1_wp*q_cons_vf(i)%sf(j, k, l)**2/rho end do - ! calculating the total energy that MUST be preserved throughout the pT- and pTg-relaxation procedures - ! at each of the cells. The internal energy is calculated as the total energy minus the kinetic - ! energy to preserved its value at sharp interfaces + ! calculating the total energy that MUST be preserved throughout the pT- and pTg-relaxation procedures at each + ! of the cells. The internal energy is calculated as the total energy minus the kinetic energy to preserved its + ! value at sharp interfaces rhoe = q_cons_vf(E_idx)%sf(j, k, l) - dynE - ! Calling pT-equilibrium for either finishing phase-change module, or as an IC for the pTg-equilibrium - ! for this case, MFL cannot be either 0 or 1, so I chose it to be 2 + ! Calling pT-equilibrium for either finishing phase-change module, or as an IC for the pTg-equilibrium for this + ! case, MFL cannot be either 0 or 1, so I chose it to be 2 call s_infinite_pt_relaxation_k(j, k, l, 2, pS, p_infpT, q_cons_vf, rhoe, TS) - ! check if pTg-equilibrium is required - ! NOTE that NOTHING else needs to be updated OTHER than the individual partial densities - ! given the outputs from the pT- and pTg-equilibrium solvers are just p and one of the partial masses - ! (pTg- case) + ! check if pTg-equilibrium is required NOTE that NOTHING else needs to be updated OTHER than the individual + ! partial densities given the outputs from the pT- and pTg-equilibrium solvers are just p and one of the partial + ! masses (pTg- case) if ((relax_model == 6) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, & & l) > mixM*rM) .and. (q_cons_vf(vp + contxb - 1)%sf(j, k, & & l) > mixM*rM)) .and. (pS < pCr) .and. (TS < TCr)) then - ! Checking if phase change is needed, by checking whether the final solution is either subcoooled - ! liquid or overheated vapor. + ! Checking if phase change is needed, by checking whether the final solution is either subcoooled liquid or + ! overheated vapor. - ! overheated vapor case - ! depleting the mass of liquid + ! overheated vapor case depleting the mass of liquid q_cons_vf(lp + contxb - 1)%sf(j, k, l) = mixM*rM ! transferring the total mass to vapor @@ -162,8 +165,7 @@ contains ! calculating Saturation temperature call s_TSat(pSOV, TSatOV, TSOV) - ! subcooled liquid case - ! transferring the total mass to liquid + ! subcooled liquid case transferring the total mass to liquid q_cons_vf(lp + contxb - 1)%sf(j, k, l) = (1.0_wp - mixM)*rM ! depleting the mass of vapor @@ -202,8 +204,7 @@ contains q_cons_vf(vp + contxb - 1)%sf(j, k, l) = mixM*rM else - ! returning partial pressures to what they were from the homogeneous solver - ! liquid + ! returning partial pressures to what they were from the homogeneous solver liquid q_cons_vf(lp + contxb - 1)%sf(j, k, l) = m1 ! vapor @@ -253,6 +254,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_infinite_relaxation_k !> This auxiliary subroutine is created to activate the pT-equilibrium for N fluids @@ -266,6 +268,7 @@ contains !! @param rhoe mixture energy !! @param TS equilibrium temperature at the interface subroutine s_infinite_pt_relaxation_k(j, k, l, MFL, pS, p_infpT, q_cons_vf, rhoe, TS) + $:GPU_ROUTINE(function_name='s_infinite_pt_relaxation_k', parallelism='[seq]', cray_noinline=True) ! initializing variables @@ -307,8 +310,7 @@ contains ! Checking energy constraint if ((rhoe - mQ - minval(p_infpT)) < 0.0_wp) then if ((MFL == 0) .or. (MFL == 1)) then - ! Assigning zero values for mass depletion cases - ! pressure + ! Assigning zero values for mass depletion cases pressure pS = 0.0_wp ! temperature @@ -318,12 +320,12 @@ contains end if end if - ! calculating initial estimate for pressure in the pT-relaxation procedure. I will also use this variable to - ! iterate over the Newton's solver + ! calculating initial estimate for pressure in the pT-relaxation procedure. I will also use this variable to iterate over + ! the Newton's solver pO = 0.0_wp - ! Maybe improve this condition afterwards. As long as the initial guess is in between -min(ps_inf) - ! and infinity, a solution should be able to be found. + ! Maybe improve this condition afterwards. As long as the initial guess is in between -min(ps_inf) and infinity, a solution + ! should be able to be found. pS = 1.0e4_wp ! Newton Solver for the pT-equilibrium @@ -343,7 +345,7 @@ contains gp = gp + (gs_min(i) - 1.0_wp)*q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*(rhoe + pS - mQ)/(mCP*(pS + p_infpT(i))) gpp = gpp + (gs_min(i) - 1.0_wp)*q_cons_vf(i + contxb - 1)%sf(j, k, & - & l)*cvs(i)*(p_infpT(i) - rhoe + mQ)/(mCP*(pS + p_infpT(i))**2) + & l)*cvs(i)*(p_infpT(i) - rhoe + mQ)/(mCP*(pS + p_infpT(i))**2) end do hp = 1.0_wp/(rhoe + pS - mQ) + 1.0_wp/(pS + minval(p_infpT)) @@ -354,6 +356,7 @@ contains ! common temperature TS = (rhoe + pS - mQ)/mCP + end subroutine s_infinite_pt_relaxation_k !> This auxiliary subroutine is created to activate the pTg-equilibrium for N fluids under pT and 2 fluids under @@ -367,6 +370,7 @@ contains !! @param q_cons_vf Cell-average conservative variables !! @param TS equilibrium temperature at the interface subroutine s_infinite_ptg_relaxation_k(j, k, l, pS, p_infpT, rhoe, q_cons_vf, TS) + $:GPU_ROUTINE(function_name='s_infinite_ptg_relaxation_k', parallelism='[seq]', cray_noinline=True) integer, intent(in) :: j, k, l @@ -386,11 +390,9 @@ contains real(wp) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver real(wp) :: ml, mT, dFdT, dTdm, dTdp - !< Generic loop iterators + !> Generic loop iterators integer :: i, ns - ! pTg-equilibrium solution procedure - ! Newton Solver parameters - ! counter + ! pTg-equilibrium solution procedure Newton Solver parameters counter ns = 0 ! Relaxation factor @@ -404,23 +406,20 @@ contains pS = 1.0e4_wp end if - ! Loop until the solution for F(X) is satisfied - ! Check whether I need to use both absolute and relative values - ! for the residual, and how to do it adequately. - ! Dummy guess to start the pTg-equilibrium problem. - ! improve this initial condition + ! Loop until the solution for F(X) is satisfied Check whether I need to use both absolute and relative values for the + ! residual, and how to do it adequately. Dummy guess to start the pTg-equilibrium problem. improve this initial condition R2D(1) = 0.0_wp; R2D(2) = 0.0_wp DeltamP(1) = 0.0_wp; DeltamP(2) = 0.0_wp do while (((sqrt(R2D(1)**2 + R2D(2)**2) > ptgalpha_eps) .and. ((sqrt(R2D(1)**2 + R2D(2)**2)/rhoe) > (ptgalpha_eps/1.e6_wp) & - & )) .or. (ns == 0)) + & )) .or. (ns == 0)) ! Updating counter for the iterative procedure ns = ns + 1 ! Auxiliary variables to help in the calculation of the residue mCP = 0.0_wp; mCPD = 0.0_wp; mCVGP = 0.0_wp; mCVGP2 = 0.0_wp; mQ = 0.0_wp; mQD = 0.0_wp - ! Those must be updated through the iterations, as they either depend on - ! the partial masses for all fluids, or on the equilibrium pressure + ! Those must be updated through the iterations, as they either depend on the partial masses for all fluids, or on the + ! equilibrium pressure $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids ! sum of the total alpha*rho*cp of the system @@ -429,8 +428,7 @@ contains ! sum of the total alpha*rho*q of the system mQ = mQ + q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) - ! These auxiliary variables now need to be updated, as the partial densities now - ! vary at every iteration + ! These auxiliary variables now need to be updated, as the partial densities now vary at every iteration if ((i /= lp) .and. (i /= vp)) then mCVGP = mCVGP + q_cons_vf(i + contxb - 1)%sf(j, k, l)*cvs(i)*(gs_min(i) - 1)/(pS + ps_inf(i)) @@ -452,21 +450,19 @@ contains mT = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, l) TS = 1/(mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp) & - & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) dFdT = -(cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*log(TS) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) - 1)*log(pS & - & + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pS + ps_inf(vp)) + & + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pS + ps_inf(vp)) dTdm = -(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)))*TS**2 dTdp = (mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp))**2 + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp))**2 - cvs(vp) & - & *(gs_min(vp) - 1)/(pS + ps_inf(vp))**2) + mCVGP2)*TS**2 + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))**2) + mCVGP2)*TS**2 - ! F = (F1,F2) is the function whose roots we are looking for - ! x = (m1, p) are the independent variables. m1 = mass of the first participant fluid, p = pressure - ! F1 = 0 is the Gibbs free energy quality - ! F2 = 0 is the enforcement of the thermodynamic (total - kinectic) energy - ! dF1dm + ! F = (F1,F2) is the function whose roots we are looking for x = (m1, p) are the independent variables. m1 = mass of the + ! first participant fluid, p = pressure F1 = 0 is the Gibbs free energy quality F2 = 0 is the enforcement of the + ! thermodynamic (total - kinectic) energy dF1dm Jac(1, 1) = dFdT*dTdm ! dF1dp @@ -506,8 +502,7 @@ contains DeltamP(1) = -1.0_wp*(InvJac(1, 1)*R2D(1) + InvJac(1, 2)*R2D(2)) DeltamP(2) = -1.0_wp*(InvJac(2, 1)*R2D(1) + InvJac(2, 2)*R2D(2)) - ! updating two reacting 'masses'. Recall that inert 'masses' do not change during the phase change - ! liquid + ! updating two reacting 'masses'. Recall that inert 'masses' do not change during the phase change liquid q_cons_vf(lp + contxb - 1)%sf(j, k, l) = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + Om*DeltamP(1) ! gas @@ -516,8 +511,8 @@ contains ! updating pressure pS = pS + Om*DeltamP(2) - ! calculating residuals, which are (i) the difference between the Gibbs Free energy of the gas and the liquid - ! and (ii) the energy before and after the phase-change process. + ! calculating residuals, which are (i) the difference between the Gibbs Free energy of the gas and the liquid and (ii) + ! the energy before and after the phase-change process. ! mass of the reacting liquid ml = q_cons_vf(lp + contxb - 1)%sf(j, k, l) @@ -526,7 +521,7 @@ contains mT = q_cons_vf(lp + contxb - 1)%sf(j, k, l) + q_cons_vf(vp + contxb - 1)%sf(j, k, l) TS = 1/(mT*cvs(vp)*(gs_min(vp) - 1)/(pS + ps_inf(vp)) + ml*(cvs(lp)*(gs_min(lp) - 1)/(pS + ps_inf(lp)) - cvs(vp) & - & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) + & *(gs_min(vp) - 1)/(pS + ps_inf(vp))) + mCVGP) ! Gibbs Free Energy Equality condition (DG) R2D(1) = TS*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*(1 - log(TS)) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) & @@ -540,6 +535,7 @@ contains ! common temperature TS = (rhoe + pS - mQ)/mCP + end subroutine s_infinite_ptg_relaxation_k !> This auxiliary subroutine corrects the partial densities of the REACTING fluids in case one of them is negative but their sum @@ -551,6 +547,7 @@ contains !! @param k generic loop iterator for y direction !! @param l generic loop iterator for z direction subroutine s_correct_partial_densities(MCT, q_cons_vf, rM, j, k, l) + $:GPU_ROUTINE(function_name='s_correct_partial_densities', parallelism='[seq]', cray_noinline=True) !> @name variables for the correction of the reacting partial densities @@ -571,8 +568,8 @@ contains end if end if - ! Defining the correction in terms of an absolute value might not be the best practice. - ! Maybe a good way to do this is to partition the partial densities, giving a small percentage of the total reacting density + ! Defining the correction in terms of an absolute value might not be the best practice. Maybe a good way to do this is to + ! partition the partial densities, giving a small percentage of the total reacting density MCT = 2*mixM ! correcting the partial densities of the reacting fluids. What to do for the nonreacting ones? @@ -585,13 +582,15 @@ contains q_cons_vf(vp + contxb - 1)%sf(j, k, l) = MCT*rM end if + end subroutine s_correct_partial_densities - !> This auxiliary subroutine finds the Saturation temperature for a given saturation pressure through a newton solver + !> This auxiliary subroutine finds the Saturation temperature for a given saturation pressure through a newton solver !! @param pSat Saturation Pressure !! @param TSat Saturation Temperature !! @param TSIn equilibrium Temperature elemental subroutine s_TSat(pSat, TSat, TSIn) + $:GPU_ROUTINE(function_name='s_TSat',parallelism='[seq]', cray_noinline=True) real(wp), intent(in) :: pSat @@ -606,8 +605,8 @@ contains TSat = 0.0_wp else - ! calculating initial estimate for temperature in the TSat procedure. I will also use this variable to - ! iterate over the Newton's solver + ! calculating initial estimate for temperature in the TSat procedure. I will also use this variable to iterate over the + ! Newton's solver TSat = TSIn ! iteration counter @@ -616,9 +615,8 @@ contains ! underrelaxation factor Om = 1.0e-3_wp - ! FT must be initialized before the do while condition is evaluated. - ! Fortran .or. is not short-circuit: abs(FT) is always evaluated even - ! when ns == 0, so FT must have a defined value here. + ! FT must be initialized before the do while condition is evaluated. Fortran .or. is not short-circuit: abs(FT) is + ! always evaluated even when ns == 0, so FT must have a defined value here. FT = huge(1.0_wp) do while ((abs(FT) > ptgalpha_eps) .or. (ns == 0)) @@ -627,11 +625,11 @@ contains ! calculating residual FT = TSat*((cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*(1 - log(TSat)) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) & - & - 1)*log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp))) + qvs(lp) - qvs(vp) + & - 1)*log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp))) + qvs(lp) - qvs(vp) ! calculating the jacobian dFdT = -(cvs(lp)*gs_min(lp) - cvs(vp)*gs_min(vp))*log(TSat) - (qvps(lp) - qvps(vp)) + cvs(lp)*(gs_min(lp) - 1) & - & *log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp)) + & *log(pSat + ps_inf(lp)) - cvs(vp)*(gs_min(vp) - 1)*log(pSat + ps_inf(vp)) ! updating saturation temperature TSat = TSat - Om*FT/dFdT @@ -639,11 +637,12 @@ contains if (abs(FT) <= ptgalpha_eps) exit end do end if + end subroutine s_TSat !> This subroutine finalizes the phase change module impure subroutine s_finalize_relaxation_solver_module - end subroutine s_finalize_relaxation_solver_module + end subroutine s_finalize_relaxation_solver_module #endif end module m_phase_change diff --git a/src/common/m_precision_select.f90 b/src/common/m_precision_select.f90 index ac96bfc9e8..414dbf1940 100644 --- a/src/common/m_precision_select.f90 +++ b/src/common/m_precision_select.f90 @@ -3,6 +3,7 @@ !> @brief Working-precision kind selection (half/single/double) and corresponding MPI datatype parameters module m_precision_select + ! use, intrinsic :: iso_c_binding #ifdef MFC_MPI diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 232ea7815f..ceebbe5f0b 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -7,10 +7,11 @@ !> @brief Conservative-to-primitive variable conversion, mixture property evaluation, and pressure computation module m_variables_conversion - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_helper use m_thermochem, only: num_species, get_temperature, get_pressure, gas_constant, get_mixture_molecular_weight, & & get_mixture_energy_mass @@ -54,6 +55,7 @@ module m_variables_conversion real(wp), allocatable, dimension(:,:,:), public :: gamma_sf !< Scalar sp. heat ratio function real(wp), allocatable, dimension(:,:,:), public :: pi_inf_sf !< Scalar liquid stiffness function real(wp), allocatable, dimension(:,:,:), public :: qv_sf !< Scalar liquid energy reference function + contains !> Dispatch to the s_convert_mixture_to_mixture_variables and s_convert_species_to_mixture_variables subroutines. Replaces a @@ -70,6 +72,7 @@ contains !! @param G_K Shear modulus (optional) !! @param G Shear moduli of the fluids (optional) subroutine s_convert_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv, Re_K, G_K, G) + type(scalar_field), dimension(sys_size), intent(in) :: q_vf integer, intent(in) :: i, j, k real(wp), intent(out), target :: rho, gamma, pi_inf, qv @@ -82,24 +85,26 @@ contains else ! Volume fraction model call s_convert_species_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv, Re_K, G_K, G) end if + end subroutine s_convert_to_mixture_variables !> This procedure conditionally calculates the appropriate pressure - !! @param energy Energy - !! @param alf Void Fraction - !! @param dyn_p Dynamic Pressure - !! @param pi_inf Liquid Stiffness - !! @param gamma Specific Heat Ratio - !! @param rho Density - !! @param qv fluid reference energy - !! @param rhoYks Species partial densities - !! @param pres Pressure to calculate - !! @param T Temperature - !! @param stress Shear Stress - !! @param mom Momentum - !! @param G Shear modulus (optional) - !! @param pres_mag Magnetic pressure (optional) + !! @param energy Energy + !! @param alf Void Fraction + !! @param dyn_p Dynamic Pressure + !! @param pi_inf Liquid Stiffness + !! @param gamma Specific Heat Ratio + !! @param rho Density + !! @param qv fluid reference energy + !! @param rhoYks Species partial densities + !! @param pres Pressure to calculate + !! @param T Temperature + !! @param stress Shear Stress + !! @param mom Momentum + !! @param G Shear modulus (optional) + !! @param pres_mag Magnetic pressure (optional) subroutine s_compute_pressure(energy, alf, dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, stress, mom, G, pres_mag) + $:GPU_ROUTINE(function_name='s_compute_pressure',parallelism='[seq]', cray_noinline=True) real(stp), intent(in) :: energy, alf @@ -118,8 +123,8 @@ contains real(wp) :: T_guess integer :: s !< Generic loop iterator #:if not chemistry - ! Depending on model_eqns and bubbles_euler, the appropriate procedure - ! for computing pressure is targeted by the procedure pointer + ! Depending on model_eqns and bubbles_euler, the appropriate procedure for computing pressure is targeted by the + ! procedure pointer if (mhd) then pres = (energy - dyn_p - pi_inf - qv - pres_mag)/gamma @@ -157,19 +162,21 @@ contains call get_temperature(e_Per_Kg - Pdyn_Per_Kg, T_guess, Y_rs, .true., T) call get_pressure(rho, T, Y_rs, pres) #:endif + end subroutine s_compute_pressure !> This subroutine is designed for the gamma/pi_inf model and provided a set of either conservative or primitive variables, !! transfers the density, specific heat ratio function and the liquid stiffness function from q_vf to rho, gamma and pi_inf. - !! @param q_vf conservative or primitive variables - !! @param i cell index to transfer mixture variables - !! @param j cell index to transfer mixture variables - !! @param k cell index to transfer mixture variables - !! @param rho density - !! @param gamma specific heat ratio function - !! @param pi_inf liquid stiffness - !! @param qv fluid reference energy + !! @param q_vf conservative or primitive variables + !! @param i cell index to transfer mixture variables + !! @param j cell index to transfer mixture variables + !! @param k cell index to transfer mixture variables + !! @param rho density + !! @param gamma specific heat ratio function + !! @param pi_inf liquid stiffness + !! @param qv fluid reference energy subroutine s_convert_mixture_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv) + type(scalar_field), dimension(sys_size), intent(in) :: q_vf integer, intent(in) :: i, j, k real(wp), intent(out), target :: rho @@ -177,8 +184,8 @@ contains real(wp), intent(out), target :: pi_inf real(wp), intent(out), target :: qv - ! Transferring the density, the specific heat ratio function and the - ! liquid stiffness function, respectively + ! Transferring the density, the specific heat ratio function and the liquid stiffness function, respectively + rho = q_vf(1)%sf(i, j, k) gamma = q_vf(gamma_idx)%sf(i, j, k) pi_inf = q_vf(pi_inf_idx)%sf(i, j, k) @@ -191,23 +198,25 @@ contains pi_inf_sf(i, j, k) = pi_inf qv_sf(i, j, k) = qv #endif + end subroutine s_convert_mixture_to_mixture_variables !> This subroutine is designed for the volume fraction model and provided a set of either conservative or primitive variables, !! computes the density, the specific heat ratio function and the liquid stiffness function from q_vf and stores the results !! into rho, gamma and pi_inf. - !! @param q_vf primitive variables - !! @param k Cell index - !! @param l Cell index - !! @param r Cell index - !! @param rho density - !! @param gamma specific heat ratio - !! @param pi_inf liquid stiffness - !! @param qv fluid reference energy - !! @param Re_K Reynolds number (optional) - !! @param G_K Shear modulus (optional) - !! @param G Shear moduli of the fluids (optional) + !! @param q_vf primitive variables + !! @param k Cell index + !! @param l Cell index + !! @param r Cell index + !! @param rho density + !! @param gamma specific heat ratio + !! @param pi_inf liquid stiffness + !! @param qv fluid reference energy + !! @param Re_K Reynolds number (optional) + !! @param G_K Shear modulus (optional) + !! @param G Shear moduli of the fluids (optional) subroutine s_convert_species_to_mixture_variables(q_vf, k, l, r, rho, gamma, pi_inf, qv, Re_K, G_K, G) + type(scalar_field), dimension(sys_size), intent(in) :: q_vf integer, intent(in) :: k, l, r real(wp), intent(out), target :: rho @@ -219,13 +228,12 @@ contains real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K real(wp), optional, dimension(num_fluids), intent(in) :: G integer :: i, j !< Generic loop iterator - ! Computing the density, the specific heat ratio function and the - ! liquid stiffness function, respectively + ! Computing the density, the specific heat ratio function and the liquid stiffness function, respectively + call s_compute_species_fraction(q_vf, k, l, r, alpha_rho_K, alpha_K) - ! Calculating the density, the specific heat ratio function, the - ! liquid stiffness function, and the energy reference function, - ! respectively, from the species analogs + ! Calculating the density, the specific heat ratio function, the liquid stiffness function, and the energy reference + ! function, respectively, from the species analogs if (num_fluids == 1 .and. bubbles_euler) then rho = alpha_rho_K(1) gamma = gammas(1) @@ -271,11 +279,13 @@ contains pi_inf_sf(k, l, r) = pi_inf qv_sf(k, l, r) = qv #endif + end subroutine s_convert_species_to_mixture_variables !> @brief GPU-accelerated conversion of species volume fractions and partial densities to mixture density, gamma, pi_inf, and !! qv. subroutine s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K, G_K, G) + $:GPU_ROUTINE(function_name='s_convert_species_to_mixture_variables_acc', parallelism='[seq]', cray_noinline=True) real(wp), intent(out) :: rho_K, gamma_K, pi_inf_K, qv_K @@ -291,10 +301,9 @@ contains real(wp) :: alpha_K_sum integer :: i, j !< Generic loop iterators #ifdef MFC_SIMULATION - ! Constraining the partial densities and the volume fractions within - ! their physical bounds to make sure that any mixture variables that - ! are derived from them result within the limits that are set by the - ! fluids physical parameters that make up the mixture + ! Constraining the partial densities and the volume fractions within their physical bounds to make sure that any mixture + ! variables that are derived from them result within the limits that are set by the fluids physical parameters that make up + ! the mixture if (num_fluids == 1 .and. bubbles_euler) then rho_K = alpha_rho_K(1) gamma_K = gammas(1) @@ -322,8 +331,7 @@ contains if (present(G_K)) then G_K = 0._wp do i = 1, num_fluids - ! TODO: change to use Gs_vc directly here? - ! TODO: Make this changes as well for GPUs + ! TODO: change to use Gs_vc directly here? TODO: Make this changes as well for GPUs G_K = G_K + alpha_K(i)*G(i) end do G_K = max(0._wp, G_K) @@ -343,11 +351,13 @@ contains end do end if #endif + end subroutine s_convert_species_to_mixture_variables_acc !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_variables_conversion_module + integer :: i, j $:GPU_ENTER_DATA(copyin='[is1b, is1e, is2b, is2e, is3b, is3e]') @@ -396,8 +406,7 @@ contains end if #ifdef MFC_POST_PROCESS - ! Allocating the density, the specific heat ratio function and the - ! liquid stiffness function, respectively + ! Allocating the density, the specific heat ratio function and the liquid stiffness function, respectively ! Simulation is at least 2D if (n > 0) then @@ -426,10 +435,12 @@ contains allocate (qv_sf(-buff_size:m + buff_size, 0:0, 0:0)) end if #endif + end subroutine s_initialize_variables_conversion_module !> @brief Initializes bubble mass-vapor values at quadrature nodes from the conserved moment statistics. subroutine s_initialize_mv(qK_cons_vf, mv) + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: mv integer :: i, j, k, l @@ -453,10 +464,12 @@ contains end do end do end do + end subroutine s_initialize_mv !> @brief Initializes bubble internal pressures at quadrature nodes using isothermal relations from the Preston model. subroutine s_initialize_pb(qK_cons_vf, mv, pb) + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(in) :: mv real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: pb @@ -475,25 +488,27 @@ contains ! PRESTON (ISOTHERMAL) pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 1, & - & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 2, & - & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + & i))/(mu - sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 3, & - & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_g0(i) + mv(j, k, l, 4, & - & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) + & i))/(mu + sig)**(3._wp)/(mass_g0(i) + mass_v0(i)) end do end do end do end do + end subroutine s_initialize_pb - !> The following procedure handles the conversion between the conservative variables and the primitive variables. - !! @param qK_cons_vf Conservative variables - !! @param q_T_sf Temperature scalar field - !! @param qK_prim_vf Primitive variables - !! @param ibounds Index bounds in each coordinate direction + !> The following procedure handles the conversion between the conservative variables and the primitive variables. + !! @param qK_cons_vf Conservative variables + !! @param q_T_sf Temperature scalar field + !! @param qK_prim_vf Primitive variables + !! @param ibounds Index bounds in each coordinate direction subroutine s_convert_conservative_to_primitive_variables(qK_cons_vf, q_T_sf, qK_prim_vf, ibounds) + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(inout) :: qK_prim_vf @@ -526,7 +541,8 @@ contains integer :: iter ! Newton-Raphson iteration counter $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_K, alpha_rho_K, Re_K, nRtmp, rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K, & - & rhoYks, B, pres, vftmp, nbub_sc, G_K, T, pres_mag, Ga, B2, m2, S, W, dW, E, D, f, dGa_dW, dp_dW, df_dW, iter]') + & rhoYks, B, pres, vftmp, nbub_sc, G_K, T, pres_mag, Ga, B2, m2, S, W, dW, E, D, f, dGa_dW, dp_dW, & + & df_dW, iter]') do l = ibounds(3)%beg, ibounds(3)%end do k = ibounds(2)%beg, ibounds(2)%end do j = ibounds(1)%beg, ibounds(1)%end @@ -539,16 +555,16 @@ contains ! If in simulation, use acc mixture subroutines if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K, G_K, Gs_vc) + & Re_K, G_K, Gs_vc) else call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K) + & Re_K) end if #else ! If pre-processing, use non acc mixture subroutines if (elasticity) then call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, rho_K, gamma_K, pi_inf_K, qv_K, Re_K, G_K, & - & fluid_pp(:)%G) + & fluid_pp(:)%G) else call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, rho_K, gamma_K, pi_inf_K, qv_K) end if @@ -595,11 +611,10 @@ contains pres = (W - D*Ga)/((gamma_K + 1)*Ga**2) ! Thermal pressure from EOS f = W - pres + (1 - 1/(2*Ga**2))*B2 - S**2/(2*W**2) - E - D - ! The first equation below corrects a typo in (Mignone & Bodo, 2006) - ! m2*W**2 -> 2*m2*W**2, which would cancel with the 2* in other terms - ! This corrected version is not used as the second equation empirically converges faster. - ! First equation is kept for further investigation. - ! dGa_dW = -Ga**3 * ( S**2*(3*W**2+3*W*B2+B2**2) + m2*W**2 ) / (W**3 * (W+B2)**3) ! first (corrected) + ! The first equation below corrects a typo in (Mignone & Bodo, 2006) m2*W**2 -> 2*m2*W**2, which would + ! cancel with the 2* in other terms This corrected version is not used as the second equation + ! empirically converges faster. First equation is kept for further investigation. dGa_dW = -Ga**3 * ( + ! S**2*(3*W**2+3*W*B2+B2**2) + m2*W**2 ) / (W**3 * (W+B2)**3) ! first (corrected) dGa_dW = -Ga**3*(2*S**2*(3*W**2 + 3*W*B2 + B2**2) + m2*W**2)/(2*W**3*(W + B2)**3) ! second (in paper) dp_dW = (Ga*(1 + D*dGa_dW) - 2*W*dGa_dW)/((gamma_K + 1)*Ga**3) @@ -678,17 +693,17 @@ contains if (mhd) then if (n == 0) then pres_mag = 0.5_wp*(Bx0**2 + qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, & - & l)**2) + & l)**2) else pres_mag = 0.5_wp*(qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, & - & l)**2 + qK_cons_vf(B_idx%beg + 2)%sf(j, k, l)**2) + & l)**2 + qK_cons_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if else pres_mag = 0._wp end if call s_compute_pressure(qK_cons_vf(E_idx)%sf(j, k, l), qK_cons_vf(alf_idx)%sf(j, k, l), dyn_pres_K, pi_inf_K, & - & gamma_K, rho_K, qv_K, rhoYks, pres, T, pres_mag=pres_mag) + & gamma_K, rho_K, qv_K, rhoYks, pres, T, pres_mag=pres_mag) qK_prim_vf(E_idx)%sf(j, k, l) = pres @@ -753,11 +768,11 @@ contains ! subtracting elastic contribution for pressure calculation if (G_K > verysmall) then qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - ((qK_prim_vf(i)%sf(j, k, & - & l)**2._wp)/(4._wp*G_K))/gamma_K + & l)**2._wp)/(4._wp*G_K))/gamma_K ! Double for shear stresses if (any(i == shear_indices)) then qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - ((qK_prim_vf(i)%sf(j, k, & - & l)**2._wp)/(4._wp*G_K))/gamma_K + & l)**2._wp)/(4._wp*G_K))/gamma_K end if end if end do @@ -791,18 +806,19 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_convert_conservative_to_primitive_variables - !> The following procedure handles the conversion between the primitive variables and the conservative variables. + !> The following procedure handles the conversion between the primitive variables and the conservative variables. !! @param q_prim_vf Primitive variables !! @param q_cons_vf Conservative variables impure subroutine s_convert_primitive_to_conservative_variables(q_prim_vf, q_cons_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - ! Density, specific heat ratio function, liquid stiffness function - ! and dynamic pressure, as defined in the incompressible flow sense, - ! respectively + ! Density, specific heat ratio function, liquid stiffness function and dynamic pressure, as defined in the incompressible + ! flow sense, respectively real(wp) :: rho real(wp) :: gamma real(wp) :: pi_inf @@ -832,8 +848,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - ! Obtaining the density, specific heat ratio function - ! and the liquid stiffness function, respectively + ! Obtaining the density, specific heat ratio function and the liquid stiffness function, respectively call s_convert_to_mixture_variables(q_prim_vf, j, k, l, rho, gamma, pi_inf, qv, Re_K, G, fluid_pp(:)%G) if (.not. igr .or. num_fluids > 1) then @@ -901,8 +916,7 @@ contains q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) end do - ! Zeroing out the dynamic pressure since it is computed - ! iteratively by cycling through the velocity equations + ! Zeroing out the dynamic pressure since it is computed iteratively by cycling through the velocity equations dyn_pres = 0._wp ! Computing momenta and dynamic pressure from velocity @@ -927,10 +941,10 @@ contains if (mhd) then if (n == 0) then pres_mag = 0.5_wp*(Bx0**2 + q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, & - & k, l)**2) + & k, l)**2) else pres_mag = 0.5_wp*(q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, & - & l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) + & l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if q_cons_vf(E_idx)%sf(j, k, l) = gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pres_mag + pi_inf + qv else if ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then @@ -939,7 +953,7 @@ contains else if ((model_eqns /= 4) .and. (bubbles_euler)) then ! \tilde{E} = dyn_pres + (1-\alf)(\Gamma p_l + \Pi_inf) q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + (1._wp - q_prim_vf(alf_idx)%sf(j, k, & - & l))*(gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) + & l))*(gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) else ! Tait EOS, no conserved energy variable q_cons_vf(E_idx)%sf(j, k, l) = 0._wp @@ -951,8 +965,8 @@ contains do i = 1, num_fluids ! internal energy calculation for each of the fluids q_cons_vf(i + intxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, & - & l)*(gammas(i)*q_prim_vf(E_idx)%sf(j, k, l) + pi_infs(i)) + q_cons_vf(i + contxb - 1)%sf(j, k, & - & l)*qvs(i) + & l)*(gammas(i)*q_prim_vf(E_idx)%sf(j, k, & + & l) + pi_infs(i)) + q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) end do end if @@ -992,8 +1006,7 @@ contains end if if (elasticity) then - ! adding the elastic contribution - ! Multiply \tau to \rho \tau + ! adding the elastic contribution Multiply \tau to \rho \tau do i = strxb, strxe q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) end do @@ -1005,11 +1018,11 @@ contains ! adding elastic contribution if (G > verysmall) then q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + (q_prim_vf(i)%sf(j, k, & - & l)**2._wp)/(4._wp*G) + & l)**2._wp)/(4._wp*G) ! Double for shear stresses if (any(i == shear_indices)) then q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + (q_prim_vf(i)%sf(j, k, & - & l)**2._wp)/(4._wp*G) + & l)**2._wp)/(4._wp*G) end if end if end do @@ -1038,9 +1051,10 @@ contains call s_mpi_abort('Conversion from primitive to ' // 'conservative variables not ' // 'implemented. Exiting.') end if #endif + end subroutine s_convert_primitive_to_conservative_variables - !> The following subroutine handles the conversion between the primitive variables and the Eulerian flux variables. + !> The following subroutine handles the conversion between the primitive variables and the Eulerian flux variables. !! @param qK_prim_vf Primitive variables !! @param FK_vf Flux variables !! @param FK_src_vf Flux source variables @@ -1050,15 +1064,15 @@ contains !! @param s2b Starting boundary index in the second coordinate direction !! @param s3b Starting boundary index in the third coordinate direction subroutine s_convert_primitive_to_flux_variables(qK_prim_vf, FK_vf, FK_src_vf, is1, is2, is3, s2b, s3b) + integer, intent(in) :: s2b, s3b real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: qK_prim_vf real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: FK_vf real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, advxb:), intent(inout) :: FK_src_vf type(int_bounds_info), intent(in) :: is1, is2, is3 - ! Partial densities, density, velocity, pressure, energy, advection - ! variables, the specific heat ratio and liquid stiffness functions, - ! the shear and volume Reynolds numbers and the Weber numbers + ! Partial densities, density, velocity, pressure, energy, advection variables, the specific heat ratio and liquid stiffness + ! functions, the shear and volume Reynolds numbers and the Weber numbers #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha_rho_K real(wp), dimension(3) :: alpha_K @@ -1081,17 +1095,18 @@ contains real(wp) :: G_K real(wp) :: T_K, mix_mol_weight, R_gas integer :: i, j, k, l !< Generic loop iterators + is1b = is1%beg; is1e = is1%end is2b = is2%beg; is2e = is2%end is3b = is3%beg; is3e = is3%end $:GPU_UPDATE(device='[is1b, is2b, is3b, is1e, is2e, is3e]') - ! Computing the flux variables from the primitive variables, without - ! accounting for the contribution of either viscosity or capillarity + ! Computing the flux variables from the primitive variables, without accounting for the contribution of either viscosity or + ! capillarity #ifdef MFC_SIMULATION $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_rho_K, vel_K, alpha_K, Re_K, Y_K, rho_K, vel_K_sum, pres_K, E_K, gamma_K, & - & pi_inf_K, qv_K, G_K, T_K, mix_mol_weight, R_gas]') + & pi_inf_K, qv_K, G_K, T_K, mix_mol_weight, R_gas]') do l = is3b, is3e do k = is2b, is2e do j = is1b, is1e @@ -1119,7 +1134,7 @@ contains pres_K = qK_prim_vf(j, k, l, E_idx) if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K, G_K, Gs_vc) + & Re_K, G_K, Gs_vc) else call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K) end if @@ -1187,10 +1202,12 @@ contains end do $:END_GPU_PARALLEL_LOOP() #endif + end subroutine s_convert_primitive_to_flux_variables !> This subroutine computes partial densities and volume fractions subroutine s_compute_species_fraction(q_vf, k, l, r, alpha_rho_K, alpha_K) + $:GPU_ROUTINE(function_name='s_compute_species_fraction', parallelism='[seq]', cray_noinline=True) type(scalar_field), dimension(sys_size), intent(in) :: q_vf integer, intent(in) :: k, l, r @@ -1236,12 +1253,13 @@ contains end if if (num_fluids == 1 .and. bubbles_euler) alpha_K(1) = q_vf(advxb)%sf(k, l, r) + end subroutine s_compute_species_fraction !> @brief Deallocates fluid property arrays and post-processing fields allocated during module initialization. impure subroutine s_finalize_variables_conversion_module() - ! Deallocating the density, the specific heat ratio function and the - ! liquid stiffness function + + ! Deallocating the density, the specific heat ratio function and the liquid stiffness function #ifdef MFC_POST_PROCESS deallocate (rho_sf, gamma_sf, pi_inf_sf, qv_sf) #endif @@ -1257,11 +1275,13 @@ contains @:DEALLOCATE(bubrs_vc) end if #endif + end subroutine s_finalize_variables_conversion_module #ifndef MFC_PRE_PROCESS !> @brief Computes the speed of sound from thermodynamic state variables, supporting multiple equation-of-state models. subroutine s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, vel_sum, c_c, c, qv) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: pres @@ -1317,13 +1337,14 @@ contains c = sqrt(c) end if end if - end subroutine s_compute_speed_of_sound + end subroutine s_compute_speed_of_sound #endif #ifndef MFC_PRE_PROCESS !> @brief Computes the fast magnetosonic wave speed from the sound speed, density, and magnetic field components. subroutine s_compute_fast_magnetosonic_speed(rho, c, B, norm, c_fast, h) + $:GPU_ROUTINE(function_name='s_compute_fast_magnetosonic_speed', parallelism='[seq]', cray_noinline=True) real(wp), intent(in) :: B(3), rho, c @@ -1351,7 +1372,7 @@ contains #endif c_fast = sqrt(0.5_wp*(term + sqrt(disc))) - end subroutine s_compute_fast_magnetosonic_speed + end subroutine s_compute_fast_magnetosonic_speed #endif end module m_variables_conversion diff --git a/src/post_process/m_checker.fpp b/src/post_process/m_checker.fpp index 0d3f8c39a3..035281b88b 100644 --- a/src/post_process/m_checker.fpp +++ b/src/post_process/m_checker.fpp @@ -6,22 +6,26 @@ !> @brief Validates post-process input parameters and output format consistency module m_checker + use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none private; public :: s_check_inputs, s_check_inputs_fft + contains !> Checks compatibility of parameters in the input file. Used by the post_process stage impure subroutine s_check_inputs + end subroutine s_check_inputs !> Checks constraints on fft_wrt impure subroutine s_check_inputs_fft + integer :: num_procs_y, num_procs_z @:PROHIBIT(fft_wrt .and. MOD(n_glb+1,n+1) /= 0, "FFT WRT requires n_glb to be divisible by num_procs_y") @@ -30,5 +34,7 @@ contains num_procs_z = (p_glb + 1)/(p + 1) @:PROHIBIT(fft_wrt .and. MOD(m_glb+1,num_procs_y) /= 0, "FFT WRT requires m_glb to be divisible by num_procs_y") @:PROHIBIT(fft_wrt .and. MOD(n_glb+1,num_procs_z) /= 0, "FFT WRT requires n_glb to be divisible by num_procs_z") + end subroutine s_check_inputs_fft + end module m_checker diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index d5a3bece57..4b732bf511 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -4,13 +4,14 @@ !> @brief Reads raw simulation grid and conservative-variable data for a given time-step and fills buffer regions module m_data_input + #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_mpi_common use m_compile_specific use m_boundary_common @@ -26,9 +27,11 @@ module m_data_input !> Subroutine for reading data files !! @param t_step Current time-step to input impure subroutine s_read_abstract_data_files(t_step) + implicit none integer, intent(in) :: t_step + end subroutine s_read_abstract_data_files end interface @@ -41,6 +44,7 @@ end subroutine s_read_abstract_data_files type(integer_field), public :: ib_markers procedure(s_read_abstract_data_files), pointer :: s_read_data_files => null() + contains !> Helper subroutine to read grid data files for a given direction @@ -51,6 +55,7 @@ end subroutine s_read_abstract_data_files !! @param cc_array Cell center array to populate !! @param size_dim Size of the dimension impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_array, cc_array, size_dim) + character(len=*), intent(in) :: t_step_dir character(len=1), intent(in) :: direction real(wp), dimension(-1:), intent(out) :: cb_array @@ -61,6 +66,7 @@ impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_ logical :: file_check ! Checking whether direction_cb.dat exists + file_loc = trim(t_step_dir) // '/' // direction // '_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) @@ -78,6 +84,7 @@ impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_ ! Computing the cell-center locations cc_array(0:size_dim) = cb_array(-1:size_dim - 1) + d_array(0:size_dim)/2._wp + end subroutine s_read_grid_data_direction #ifdef MFC_MPI @@ -86,11 +93,13 @@ end subroutine s_read_grid_data_direction !! @param m_MOK, n_MOK, p_MOK MPI offset kinds for dimensions (output) !! @param WP_MOK, MOK, str_MOK, NVARS_MOK Other MPI offset kinds (output) impure subroutine s_setup_mpi_io_params(data_size, m_MOK, n_MOK, p_MOK, WP_MOK, MOK, str_MOK, NVARS_MOK) + integer, intent(out) :: data_size integer(KIND=MPI_OFFSET_KIND), intent(out) :: m_MOK, n_MOK, p_MOK integer(KIND=MPI_OFFSET_KIND), intent(out) :: WP_MOK, MOK, str_MOK, NVARS_MOK ! Initialize MPI data I/O + if (ib) then call s_initialize_mpi_data(q_cons_vf, ib_markers) else @@ -108,14 +117,15 @@ impure subroutine s_setup_mpi_io_params(data_size, m_MOK, n_MOK, p_MOK, WP_MOK, MOK = int(1._wp, MPI_OFFSET_KIND) str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - end subroutine s_setup_mpi_io_params + end subroutine s_setup_mpi_io_params #endif !> Helper subroutine to read IB data files !! @param file_loc_base Base file location for IB data !! @param t_step Time step index impure subroutine s_read_ib_data_files(file_loc_base, t_step) + character(len=*), intent(in) :: file_loc_base integer, intent(in), optional :: t_step character(LEN=len_trim(file_loc_base) + 20) :: file_loc @@ -127,6 +137,7 @@ impure subroutine s_read_ib_data_files(file_loc_base, t_step) integer(KIND=MPI_OFFSET_KIND) :: disp integer :: m_MOK, n_MOK, p_MOK, MOK, WP_MOK, save_index #endif + if (.not. ib) return if (parallel_io) then @@ -169,6 +180,7 @@ impure subroutine s_read_ib_data_files(file_loc_base, t_step) else call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if + end subroutine s_read_ib_data_files !> Helper subroutine to allocate field arrays for given dimensionality @@ -177,6 +189,7 @@ end subroutine s_read_ib_data_files !! @param end_y End index for y dimension !! @param end_z End index for z dimension impure subroutine s_allocate_field_arrays(local_start_idx, end_x, end_y, end_z) + integer, intent(in) :: local_start_idx, end_x, end_y, end_z integer :: i @@ -192,12 +205,14 @@ impure subroutine s_allocate_field_arrays(local_start_idx, end_x, end_y, end_z) if (chemistry) then allocate (q_T_sf%sf(local_start_idx:end_x, local_start_idx:end_y, local_start_idx:end_z)) end if + end subroutine s_allocate_field_arrays !> This subroutine is called at each time-step that has to be post-processed in order to read the raw data files present in the !! corresponding time-step directory and to populate the associated grid and conservative variables. !! @param t_step Current time-step impure subroutine s_read_serial_data_files(t_step) + integer, intent(in) :: t_step character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_dir !< Location of the time-step directory associated with t_step character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc !< Generic string used to store the location of a particular file @@ -205,10 +220,11 @@ impure subroutine s_read_serial_data_files(t_step) character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num !> Location of the time-step directory associated with t_step character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_ib_dir - logical :: dir_check !< Generic logical used to test the existence of a particular folder - logical :: file_check !< Generic logical used to test the existence of a particular file - integer :: i !< Generic loop iterator + logical :: dir_check !< Generic logical used to test the existence of a particular folder + logical :: file_check !< Generic logical used to test the existence of a particular file + integer :: i !< Generic loop iterator ! Setting location of time-step folder based on current time-step + write (t_step_dir, '(A,I0,A,I0)') '/p_all/p', proc_rank, '/', t_step t_step_dir = trim(case_dir) // trim(t_step_dir) @@ -240,8 +256,8 @@ impure subroutine s_read_serial_data_files(t_step) ! Reading the Conservative Variables Data Files do i = 1, sys_size - ! Checking whether the data file associated with the variable - ! position of currently manipulated conservative variable exists + ! Checking whether the data file associated with the variable position of currently manipulated conservative variable + ! exists write (file_num, '(I0)') i file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) @@ -252,8 +268,7 @@ impure subroutine s_read_serial_data_files(t_step) read (1) q_cons_vf(i)%sf(0:m, 0:n, 0:p) close (1) else if (bubbles_lagrange .and. i == beta_idx) then - ! beta (Lagrangian void fraction) is not written by pre_process - ! for t_step_start; initialize to zero. + ! beta (Lagrangian void fraction) is not written by pre_process for t_step_start; initialize to zero. q_cons_vf(i)%sf(0:m, 0:n, 0:p) = 0._wp else call s_mpi_abort('File q_cons_vf' // trim(file_num) // '.dat is missing in ' // trim(t_step_dir) // '. Exiting.') @@ -262,12 +277,14 @@ impure subroutine s_read_serial_data_files(t_step) ! Reading IB data using helper subroutine call s_read_ib_data_files(t_step_dir) + end subroutine s_read_serial_data_files !> This subroutine is called at each time-step that has to be post-processed in order to parallel-read the raw data files !! present in the corresponding time-step directory and to populate the associated grid and conservative variables. !! @param t_step Current time-step impure subroutine s_read_parallel_data_files(t_step) + integer, intent(in) :: t_step #ifdef MFC_MPI @@ -392,6 +409,7 @@ impure subroutine s_read_parallel_data_files(t_step) call s_assign_default_bc_type(bc_type) end if #endif + end subroutine s_read_parallel_data_files #ifdef MFC_MPI @@ -400,6 +418,7 @@ end subroutine s_read_parallel_data_files !! @param m_MOK, n_MOK, p_MOK MPI offset kinds for dimensions !! @param WP_MOK, MOK, str_MOK, NVARS_MOK Other MPI offset kinds impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, WP_MOK, MOK, str_MOK, NVARS_MOK) + integer, intent(in) :: t_step integer(KIND=MPI_OFFSET_KIND), intent(inout) :: m_MOK, n_MOK, p_MOK integer(KIND=MPI_OFFSET_KIND), intent(inout) :: WP_MOK, MOK, str_MOK, NVARS_MOK @@ -505,23 +524,23 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if end if - end subroutine s_read_parallel_conservative_data + end subroutine s_read_parallel_conservative_data #endif - !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_data_input_module + integer :: i !< Generic loop iterator - ! Allocating the parts of the conservative and primitive variables - ! that do not require the direct knowledge of the dimensionality of - ! the simulation + ! Allocating the parts of the conservative and primitive variables that do not require the direct knowledge of the + ! dimensionality of the simulation + allocate (q_cons_vf(1:sys_size)) allocate (q_prim_vf(1:sys_size)) allocate (q_cons_temp(1:sys_size)) - ! Allocating the parts of the conservative and primitive variables - ! that do require the direct knowledge of the dimensionality of - ! the simulation using helper subroutine + ! Allocating the parts of the conservative and primitive variables that do require the direct knowledge of the + ! dimensionality of the simulation using helper subroutine ! Simulation is at least 2D if (n > 0) then @@ -561,12 +580,15 @@ impure subroutine s_initialize_data_input_module else s_read_data_files => s_read_parallel_data_files end if + end subroutine s_initialize_data_input_module !> Deallocation procedures for the module impure subroutine s_finalize_data_input_module + integer :: i !< Generic loop iterator ! Deallocating the conservative and primitive variables + do i = 1, sys_size deallocate (q_cons_vf(i)%sf) deallocate (q_prim_vf(i)%sf) @@ -598,5 +620,7 @@ impure subroutine s_finalize_data_input_module deallocate (bc_type) s_read_data_files => null() + end subroutine s_finalize_data_input_module + end module m_data_input diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index cadf5a245e..d08d522c37 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -4,6 +4,7 @@ !> @brief Writes post-processed grid and flow-variable data to Silo-HDF5 or binary database files module m_data_output + use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters use m_derived_variables !< Procedures used to compute quantities derived @@ -21,15 +22,13 @@ module m_data_output & s_write_energy_data_file, s_close_formatted_database_file, s_close_intf_data_file, s_close_energy_data_file, & & s_finalize_data_output_module - ! Including the Silo Fortran interface library that features the subroutines - ! and parameters that are required to write in the Silo-HDF5 database format - ! INCLUDE 'silo.inc' + ! Including the Silo Fortran interface library that features the subroutines and parameters that are required to write in the + ! Silo-HDF5 database format INCLUDE 'silo.inc' include 'silo_f9x.inc' - ! Generic storage for flow variable(s) that are to be written to formatted - ! database file(s). Note that for 1D simulations, q_root_sf is employed to - ! gather the flow variable(s) from all sub-domains on to the root process. - ! If the run is not parallel, but serial, then q_root_sf is equal to q_sf. + ! Generic storage for flow variable(s) that are to be written to formatted database file(s). Note that for 1D simulations, + ! q_root_sf is employed to gather the flow variable(s) from all sub-domains on to the root process. If the run is not parallel, + ! but serial, then q_root_sf is equal to q_sf. real(wp), allocatable, dimension(:,:,:), public :: q_sf real(wp), allocatable, dimension(:,:,:) :: q_root_sf real(wp), allocatable, dimension(:,:,:) :: cyl_q_sf @@ -39,62 +38,54 @@ module m_data_output real(sp), allocatable, dimension(:,:,:) :: q_root_sf_s real(sp), allocatable, dimension(:,:,:) :: cyl_q_sf_s - ! The spatial and data extents array variables contain information about the - ! minimum and maximum values of the grid and flow variable(s), respectively. - ! The purpose of bookkeeping this information is to boost the visualization - ! of the Silo-HDF5 database file(s) in VisIt. + ! The spatial and data extents array variables contain information about the minimum and maximum values of the grid and flow + ! variable(s), respectively. The purpose of bookkeeping this information is to boost the visualization of the Silo-HDF5 database + ! file(s) in VisIt. real(wp), allocatable, dimension(:,:) :: spatial_extents real(wp), allocatable, dimension(:,:) :: data_extents - ! The size of the ghost zone layer at beginning of each coordinate direction - ! (lo) and at end of each coordinate direction (hi). Adding this information - ! to Silo-HDF5 database file(s) is recommended since it supplies VisIt with - ! connectivity information between the sub-domains of a parallel data set. + ! The size of the ghost zone layer at beginning of each coordinate direction (lo) and at end of each coordinate direction (hi). + ! Adding this information to Silo-HDF5 database file(s) is recommended since it supplies VisIt with connectivity information + ! between the sub-domains of a parallel data set. integer, allocatable, dimension(:) :: lo_offset integer, allocatable, dimension(:) :: hi_offset - ! For Silo-HDF5 database format, this variable is used to keep track of the - ! number of cell-boundaries, for the grid associated with the local process, - ! in each of the active coordinate directions. + ! For Silo-HDF5 database format, this variable is used to keep track of the number of cell-boundaries, for the grid associated + ! with the local process, in each of the active coordinate directions. 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 + ! 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. + ! 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. + ! 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 + ! Generic error flags utilized in the handling, checking and the reporting of the input and output operations errors with a + ! formatted database file integer, private :: err + contains !> @brief Allocate storage arrays, configure output directories, and count flow variables for formatted database output. impure subroutine s_initialize_data_output_module() - ! Description: Computation of parameters, allocation procedures, and/or - ! any other tasks needed to properly setup the module + + ! Description: Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module ! Generic string used to store the location of a particular file character(LEN=len_trim(case_dir) + 2*name_len) :: file_loc @@ -103,9 +94,9 @@ contains logical :: dir_check integer :: i - ! Allocating the generic storage for the flow variable(s) that are - ! going to be written to the formatted database file(s). Note once - ! more that the root variable is only required for 1D computations. + ! Allocating the generic storage for the flow variable(s) that are going to be written to the formatted database file(s). + ! Note once more that the root variable is only required for 1D computations. + allocate (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)) @@ -115,7 +106,7 @@ contains 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)) 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)) + & -offset_x%beg:m + offset_x%end)) end if end if @@ -126,10 +117,9 @@ contains end if end if - ! Allocating the 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 - ! are only needed by the Silo-HDF5 format for multidimensional data. + ! Allocating the 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 are only needed by the Silo-HDF5 format + ! for multidimensional data. if (format == 1) then allocate (data_extents(1:2, 0:num_procs - 1)) @@ -151,13 +141,10 @@ contains end if end if - ! The size of the ghost zone layer in each of the active coordinate - ! directions was set in the module m_mpi_proxy.f90. The results are - ! now transferred to the local variables of this module when they are - ! required by the Silo-HDF5 format, for multidimensional data sets. - ! With the same, latter, requirements, the variables bookkeeping the - ! number of cell-boundaries in each active coordinate direction are - ! also set here. + ! The size of the ghost zone layer in each of the active coordinate directions was set in the module m_mpi_proxy.f90. The + ! results are now transferred to the local variables of this module when they are required by the Silo-HDF5 format, for + ! multidimensional data sets. With the same, latter, requirements, the variables bookkeeping the number of cell-boundaries + ! in each active coordinate direction are also set here. if (format == 1) then if (p > 0) then if (grid_geometry == 3) then @@ -170,10 +157,10 @@ contains 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/) + & 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/) + & p + offset_z%beg + offset_z%end + 2/) end if else if (n > 0) then lo_offset(:) = (/offset_x%beg, offset_y%beg/) @@ -259,10 +246,9 @@ contains end if end if - ! Contrary to the Silo-HDF5 database format, handles of the Binary - ! database master/root and slave/local process files are perfectly - ! static throughout post-process. Hence, they are set here so that - ! they do not have to be repetitively computed in later procedures. + ! Contrary to the Silo-HDF5 database format, handles of the Binary database master/root and slave/local process files are + ! 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 == 2) then if (n == 0 .and. proc_rank == 0) dbroot = 2 dbfile = 1 @@ -271,8 +257,7 @@ contains ! Querying Number of Flow Variable(s) in Binary Output if (format == 2) then - ! Initializing the counter of the number of flow variable(s) to - ! be written to the formatted database file(s) + ! Initializing the counter of the number of flow variable(s) to be written to the formatted database file(s) dbvars = 0 ! Partial densities @@ -379,14 +364,17 @@ contains end if ! END: Querying Number of Flow Variable(s) in Binary Output + end subroutine s_initialize_data_output_module !> @brief Compute the cell-index bounds for the user-specified partial output domain in each coordinate direction. impure subroutine s_define_output_region + integer :: i integer :: lower_bound, upper_bound #:for X, M in [('x', 'm'), ('y', 'n'), ('z', 'p')] + if (${M}$ == 0) return ! Early return for y or z if simulation is 1D or 2D lower_bound = -offset_${X}$%beg @@ -412,20 +400,17 @@ contains ${X}$_output_idx%end = 0 end if #:endfor + end subroutine s_define_output_region !> @brief Open (or create) the Silo-HDF5 or Binary formatted database slave and master files for a given time step. impure subroutine s_open_formatted_database_file(t_step) - ! Description: This subroutine opens a new formatted database file, or - ! replaces an old one, and readies it for the data storage - ! of the grid and the flow variable(s) associated with the - ! current time-step, t_step. This is performed by all the - ! local process(es). The root processor, in addition, must - ! also generate a master formatted database file whose job - ! will be to link, and thus combine, the data from all of - ! the local process(es). Note that for the Binary format, - ! this extra task that is assigned to the root process is - ! not performed in multidimensions. + + ! Description: This subroutine opens a new formatted database file, or replaces an old one, and readies it for the data + ! storage of the grid and the flow variable(s) associated with the current time-step, t_step. This is performed by all the + ! local process(es). The root processor, in addition, must also generate a master formatted database file whose job will be + ! to link, and thus combine, the data from all of the local process(es). Note that for the Binary format, this extra task + ! that is assigned to the root process is not performed in multidimensions. ! Time-step that is currently being post-processed integer, intent(in) :: t_step @@ -436,25 +421,23 @@ contains ! Silo-HDF5 Database Format if (format == 1) then - ! Generating the relative path to the formatted database slave - ! file, that is to be opened for the current time-step, t_step + ! Generating the relative path to the formatted database slave file, that is to be opened for the current time-step, + ! t_step write (file_loc, '(A,I0,A)') '/', t_step, '.silo' file_loc = trim(proc_rank_dir) // trim(file_loc) - ! Creating formatted database slave file at the above location - ! and setting up the structure of the file and its header info + ! Creating formatted database slave file at the above location and setting up the structure of the file and its header + ! info ierr = DBCREATE(trim(file_loc), len_trim(file_loc), DB_CLOBBER, DB_LOCAL, 'MFC v3.0', 8, DB_HDF5, dbfile) - ! Verifying that the creation and setup process of the formatted - ! database slave file has been performed without errors. If this - ! is not the case, the post-process exits. + ! Verifying that the creation and setup process of the formatted database slave file has been performed without errors. + ! If this is not the case, the post-process exits. if (dbfile == -1) then call s_mpi_abort('Unable to create Silo-HDF5 database ' // 'slave file ' // trim(file_loc) // '. ' // 'Exiting.') end if - ! Next, analogous steps to the ones above are carried out by the - ! root process to create and setup the formatted database master - ! file. + ! Next, analogous steps to the ones above are carried out by the root process to create and setup the formatted database + ! master file. if (proc_rank == 0) then write (file_loc, '(A,I0,A)') '/collection_', t_step, '.silo' file_loc = trim(rootdir) // trim(file_loc) @@ -463,43 +446,39 @@ contains if (dbroot == -1) then call s_mpi_abort('Unable to create Silo-HDF5 database ' // 'master file ' // trim(file_loc) // '. ' & - & // 'Exiting.') + & // 'Exiting.') end if end if ! Binary Database Format else - ! Generating the relative path to the formatted database slave - ! file, that is to be opened for the current time-step, t_step + ! Generating the relative path to the formatted database slave file, that is to be opened for the current time-step, + ! t_step write (file_loc, '(A,I0,A)') '/', t_step, '.dat' file_loc = trim(proc_rank_dir) // trim(file_loc) - ! Creating the formatted database slave file, at the previously - ! precised relative path location, and setting up its structure + ! Creating the formatted database slave file, at the previously precised relative path location, and setting up its + ! structure open (dbfile, IOSTAT=err, FILE=trim(file_loc), form='unformatted', STATUS='replace') - ! Verifying that the creation and setup process of the formatted - ! database slave file has been performed without errors. If this - ! is not the case, the post-process exits. + ! Verifying that the creation and setup process of the formatted database slave file has been performed without errors. + ! If this is not the case, the post-process exits. if (err /= 0) then call s_mpi_abort('Unable to create Binary database slave ' // 'file ' // trim(file_loc) // '. Exiting.') end if - ! Further defining the structure of the formatted database slave - ! file by describing in it the dimensionality of post-processed - ! data as well as the total number of flow variable(s) that will - ! eventually be stored in it + ! Further defining the structure of the formatted database slave file by describing in it the dimensionality of + ! post-processed data as well as the total number of flow variable(s) that will eventually be stored in it 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 + & z_output_idx%end - z_output_idx%beg, dbvars else write (dbfile) m, n, p, dbvars end if - ! Next, analogous steps to the ones above are carried out by the - ! root process to create and setup the formatted database master - ! file. Note that this is only done in multidimensional cases. + ! Next, analogous steps to the ones above are carried out by the root process to create and setup the formatted database + ! master file. Note that this is only done in multidimensional cases. if (n == 0 .and. proc_rank == 0) then write (file_loc, '(A,I0,A)') '/', t_step, '.dat' file_loc = trim(rootdir) // trim(file_loc) @@ -517,55 +496,51 @@ contains end if end if end if + end subroutine s_open_formatted_database_file !> @brief Open the interface data file for appending extracted interface coordinates. impure subroutine s_open_intf_data_file() + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to a file in the case directory + write (file_path, '(A)') '/intf_data.dat' file_path = trim(case_dir) // trim(file_path) ! Opening the simulation data file open (211, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') + end subroutine s_open_intf_data_file !> @brief Open the energy data file for appending volume-integrated energy budget quantities. impure subroutine s_open_energy_data_file() + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to a file in the case directory + write (file_path, '(A)') '/eng_data.dat' file_path = trim(case_dir) // trim(file_path) ! Opening the simulation data file open (251, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') + end subroutine s_open_energy_data_file !> @brief Write the computational grid (cell-boundary coordinates) to the formatted database slave and master files. impure subroutine s_write_grid_to_formatted_database_file(t_step) - ! Description: The general objective of this subroutine is to write the - ! necessary grid data to the formatted database file, for - ! the current time-step, t_step. The local processor will - ! write the grid data of the domain segment that it is in - ! charge of to the formatted database slave file. The root - ! process will additionally take care of linking that grid - ! data in the formatted database master file. In the Silo- - ! HDF5 database format, the spatial extents of each local - ! process grid are also written to the master file. In the - ! Binary format, note that no master file is maintained in - ! multidimensions. Finally, in 1D, no grid data is written - ! within this subroutine for the Silo-HDF5 format because - ! curve objects rather than quadrilateral meshes are used. - ! For curve objects, in contrast to the quadrilateral mesh - ! objects, the grid data is included side by side with the - ! flow variable data. Then, in this case, we take care of - ! writing both the grid and the flow variable data in the - ! subroutine s_write_variable_to_formatted_database_file. - ! Time-step that is currently being post-processed + + ! Description: The general objective of this subroutine is to write the necessary grid data to the formatted database file, + ! for the current time-step, t_step. The local processor will write the grid data of the domain segment that it is in charge + ! of to the formatted database slave file. The root process will additionally take care of linking that grid data in the + ! formatted database master file. In the Silo- HDF5 database format, the spatial extents of each local process grid are also + ! written to the master file. In the Binary format, note that no master file is maintained in multidimensions. Finally, in + ! 1D, no grid data is written within this subroutine for the Silo-HDF5 format because curve objects rather than + ! quadrilateral meshes are used. For curve objects, in contrast to the quadrilateral mesh objects, the grid data is included + ! side by side with the flow variable data. Then, in this case, we take care of writing both the grid and the flow variable + ! data in the subroutine s_write_variable_to_formatted_database_file. Time-step that is currently being post-processed integer, intent(in) :: t_step - ! Bookkeeping variables storing the name and type of mesh that is - ! handled by the local processor(s). Note that due to an internal - ! NAG Fortran compiler problem, these two variables could not be - ! allocated dynamically. + ! Bookkeeping variables storing the name and type of mesh that is handled by the local processor(s). Note that due to an + ! internal NAG Fortran compiler problem, these two variables could not be allocated dynamically. character(LEN=4*name_len), dimension(num_procs) :: meshnames integer, dimension(num_procs) :: meshtypes @@ -575,10 +550,8 @@ contains ! Silo-HDF5 Database Format if (format == 1) then - ! 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. + ! 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) else if (p > 0) then @@ -593,10 +566,9 @@ contains 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 addition, it - ! also records a sub-domain connectivity map so that the entire - ! grid may be reassembled by looking at the master file. + ! Next, the root processor proceeds to record all of the spatial extents in the formatted database master file. In + ! addition, it also records a sub-domain connectivity map so that the entire grid may be reassembled by looking at the + ! master file. if (proc_rank == 0) then do i = 1, num_procs write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:rectilinear_grid' @@ -609,13 +581,12 @@ contains 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) + & ierr) err = DBFREEOPTLIST(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. + ! 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) @@ -623,10 +594,10 @@ contains err = DBADDIOPT(optlist, DBOPT_HI_OFFSET, 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) + & DB_COLLINEAR, 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) + & DB_COLLINEAR, optlist, ierr) end if err = DBFREEOPTLIST(optlist) else if (n > 0) then @@ -634,30 +605,29 @@ contains err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) err = DBADDIOPT(optlist, DBOPT_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) + & DB_COLLINEAR, optlist, ierr) err = DBFREEOPTLIST(optlist) else err = DBMKOPTLIST(2, optlist) err = DBADDIOPT(optlist, DBOPT_LO_OFFSET, lo_offset) err = DBADDIOPT(optlist, DBOPT_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) + & DB_DOUBLE, DB_COLLINEAR, optlist, ierr) err = DBFREEOPTLIST(optlist) end if ! END: Silo-HDF5 Database Format ! Binary Database Format else if (format == 2) then - ! Multidimensional local grid data is written to the formatted - ! database slave file. Recall that no master file to maintained - ! in multidimensions. + ! 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 == 1) then write (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) + & z_cb(z_output_idx%beg - 1:z_output_idx%end) else write (dbfile) x_cb, y_cb, z_cb end if @@ -673,9 +643,8 @@ contains end if end if - ! One-dimensional local grid data is written to the formatted - ! database slave file. In addition, the local grid data is put - ! together by the root process and written to the master file. + ! One-dimensional local grid data is written to the formatted database slave file. In addition, the local grid data + ! is put together by the root process and written to the master file. else if (precision == 1) then @@ -707,37 +676,29 @@ contains end if end if end if + end subroutine s_write_grid_to_formatted_database_file !> @brief Write a single flow variable field to the formatted database slave and master files for a given time step. impure subroutine s_write_variable_to_formatted_database_file(varname, t_step) - ! Description: The goal of this subroutine is to write to the formatted - ! database file the flow variable at the current time-step, - ! t_step. The local process(es) write the part of the flow - ! variable that they handle to the formatted database slave - ! file. The root process, on the other hand, will also take - ! care of connecting all of the flow variable data in the - ! formatted database master file. In the Silo-HDF5 database - ! format, the extents of each local process flow variable - ! are also written to the master file. Note that in Binary - ! format, no master file is maintained in multidimensions. - ! Finally note that in 1D, grid data is also written within - ! this subroutine for Silo-HDF5 database format since curve - ! and not the quadrilateral variable objects are used, see - ! description of s_write_grid_to_formatted_database_file - ! for more details on this topic. - - ! Name of the flow variable, which will be written to the formatted - ! database file at the current time-step, t_step + + ! Description: The goal of this subroutine is to write to the formatted database file the flow variable at the current + ! time-step, t_step. The local process(es) write the part of the flow variable that they handle to the formatted database + ! slave file. The root process, on the other hand, will also take care of connecting all of the flow variable data in the + ! formatted database master file. In the Silo-HDF5 database format, the extents of each local process flow variable are also + ! written to the master file. Note that in Binary format, no master file is maintained in multidimensions. Finally note that + ! in 1D, grid data is also written within this subroutine for Silo-HDF5 database format since curve and not the + ! quadrilateral variable objects are used, see description of s_write_grid_to_formatted_database_file for more details on + ! this topic. + + ! Name of the flow variable, which will be written to the formatted database file at the current time-step, t_step character(LEN=*), intent(in) :: varname ! Time-step that is currently being post-processed integer, intent(in) :: t_step - ! Bookkeeping variables storing the name and type of flow variable - ! that is about to be handled by the local processor(s). Note that - ! due to an internal NAG Fortran compiler problem, these variables - ! could not be allocated dynamically. + ! Bookkeeping variables storing the name and type of flow variable that is about to be handled by the local processor(s). + ! Note that due to an internal NAG Fortran compiler problem, these variables could not be allocated dynamically. character(LEN=4*name_len), dimension(num_procs) :: varnames integer, dimension(num_procs) :: vartypes @@ -747,16 +708,14 @@ contains ! Silo-HDF5 Database Format if (format == 1) then - ! Determining the extents of the flow variable on each local - ! process and gathering all this information on root process + ! 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) else data_extents(:, 0) = (/minval(q_sf), maxval(q_sf)/) end if - ! Next, the root process proceeds to write the gathered flow - ! variable data extents to formatted database master file. + ! Next, the root process proceeds to write the gathered flow variable data extents to formatted database master file. if (proc_rank == 0) then do i = 1, num_procs write (varnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:' // trim(varname) @@ -769,12 +728,11 @@ contains 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) + & optlist, ierr) err = DBFREEOPTLIST(optlist) end if - ! Finally, each of the local processor(s) proceeds to write - ! the flow variable data that it is responsible for to the + ! Finally, each of the local processor(s) proceeds to write the flow variable data that it is responsible for to the ! formatted database slave file. if (wp == dp) then if (precision == 1) then @@ -829,17 +787,17 @@ contains 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) + & 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) + & 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) + & 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) + & 1, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) end if end if #:endfor @@ -849,17 +807,16 @@ contains ! Binary Database Format else - ! Writing the name of the flow variable and its data, associated - ! with the local processor, to the formatted database slave file + ! Writing the name of the flow variable and its data, associated with the local processor, to the formatted database + ! slave file if (precision == 1) then write (dbfile) varname, real(q_sf, wp) else write (dbfile) varname, 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. + ! 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) @@ -876,11 +833,13 @@ contains end if end if end if + end subroutine s_write_variable_to_formatted_database_file !> Subroutine that writes the post processed results in the folder 'lag_bubbles_data' !! @param t_step Current time step impure subroutine s_write_lag_bubbles_results_to_text(t_step) + integer, intent(in) :: t_step character(len=len_trim(case_dir) + 3*name_len) :: file_loc integer :: id @@ -900,6 +859,7 @@ contains integer :: i integer, dimension(:), allocatable :: proc_bubble_counts real(wp), dimension(1:1, 1:lag_io_vars) :: lag_io_null + lag_io_null = 0._wp ! Construct file path @@ -959,7 +919,7 @@ contains call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_null, ierr) allocate (MPI_IO_DATA_lg_bubbles(file_tot_part, 1:lag_io_vars)) @@ -1027,10 +987,12 @@ contains call MPI_FILE_CLOSE(ifile, ierr) #endif + end subroutine s_write_lag_bubbles_results_to_text !> @brief Read Lagrangian bubble restart data and write bubble positions and scalar fields to the Silo database. impure subroutine s_write_lag_bubbles_to_formatted_database_file(t_step) + integer, intent(in) :: t_step character(len=len_trim(case_dir) + 3*name_len) :: file_loc integer :: id @@ -1135,7 +1097,7 @@ contains ! Skip extended header disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lg_bubbles, lag_io_vars*nBub, mpi_p, status, ierr) @@ -1143,8 +1105,7 @@ contains call MPI_FILE_CLOSE(ifile, ierr) call MPI_TYPE_FREE(view, ierr) - ! Extract data from MPI_IO_DATA_lg_bubbles array - ! Adjust these indices based on your actual data layout + ! Extract data from MPI_IO_DATA_lg_bubbles array Adjust these indices based on your actual data layout #:for VAR, IDX in [('bub_id', 1), ('px', 2), ('py',3), ('pz',4), ('ppx',5), ('ppy',6), ('ppz',7), & ('vx',8), ('vy',9), ('vz',10), ('radius',11), ('rvel',12), & ('rnot',13), ('rmax',14), ('rmin',15), ('dphidt',16), & @@ -1152,10 +1113,9 @@ contains ${VAR}$ (:) = MPI_IO_DATA_lg_bubbles(:, ${IDX}$) #:endfor - ! Next, the root processor proceeds to record all of the spatial - ! extents in the formatted database master file. In addition, it - ! also records a sub-domain connectivity map so that the entire - ! grid may be reassembled by looking at the master file. + ! Next, the root processor proceeds to record all of the spatial extents in the formatted database master file. In + ! addition, it also records a sub-domain connectivity map so that the entire grid may be reassembled by looking at the + ! master file. if (proc_rank == 0) then do i = 1, num_procs write (meshnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:lag_bubbles' @@ -1186,7 +1146,7 @@ contains if (lag_betaC_wrt) call s_write_lag_variable_to_formatted_database_file('part_betaC', t_step, betaC, nBub) deallocate (bub_id, px, py, pz, ppx, ppy, ppz, vx, vy, vz, radius, rvel, rnot, rmax, rmin, dphidt, pressure, mv, mg, & - & betaT, betaC) + & betaT, betaC) deallocate (MPI_IO_DATA_lg_bubbles) else call MPI_TYPE_CONTIGUOUS(0, mpi_p, view, ierr) @@ -1196,7 +1156,7 @@ contains ! Skip extended header disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -1235,10 +1195,12 @@ contains if (lag_betaC_wrt) call s_write_lag_variable_to_formatted_database_file('part_betaC', t_step) end if #endif + end subroutine s_write_lag_bubbles_to_formatted_database_file !> @brief Write a single Lagrangian bubble point-variable to the Silo database slave and master files. subroutine s_write_lag_variable_to_formatted_database_file(varname, t_step, data, nBubs) + character(len=*), intent(in) :: varname integer, intent(in) :: t_step real(wp), dimension(1:), intent(in), optional :: data @@ -1259,7 +1221,7 @@ contains 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) + & DB_F77NULL, ierr) end if err = DBPUTPV1(dbfile, trim(varname), len_trim(varname), 'lag_bubbles', 11, data, nBubs, DB_DOUBLE, DB_F77NULL, ierr) @@ -1272,15 +1234,17 @@ contains 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) + & 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) end if + end subroutine s_write_lag_variable_to_formatted_database_file impure subroutine s_write_ib_state_files() + character(len=len_trim(case_dir) + 4*name_len) :: in_file, out_file, file_loc integer :: iu_in, ios, i, rec_id integer, allocatable, dimension(:) :: iu_out @@ -1305,19 +1269,19 @@ contains call s_mpi_abort('Cannot open IB state output file: ' // trim(out_file)) end if write (iu_out(i), & - & '(A)') 'mytime fx fy fz Tau_x Tau_y Tau_z vx vy vz omega_x omega_y omega_z angle_x angle_y angle_z x_c y_c z_c' + & '(A)') 'mytime fx fy fz Tau_x Tau_y Tau_z vx vy vz omega_x omega_y omega_z angle_x angle_y angle_z x_c y_c z_c' end do do read (iu_in, iostat=ios) rec_time, rec_id, rec_force, rec_torque, rec_vel, rec_angular_vel, rec_angles, & - & rec_centroid(1), rec_centroid(2), rec_centroid(3) + & rec_centroid(1), rec_centroid(2), rec_centroid(3) if (ios /= 0) exit if (rec_id >= 1 .and. rec_id <= num_ibs) then write (iu_out(rec_id), '(19(ES24.16E3,1X))') rec_time, rec_force(1), rec_force(2), rec_force(3), rec_torque(1), & - & rec_torque(2), rec_torque(3), rec_vel(1), rec_vel(2), rec_vel(3), rec_angular_vel(1), rec_angular_vel(2), & - & rec_angular_vel(3), rec_angles(1), rec_angles(2), rec_angles(3), rec_centroid(1), rec_centroid(2), & - & rec_centroid(3) + & rec_torque(2), rec_torque(3), rec_vel(1), rec_vel(2), rec_vel(3), rec_angular_vel(1), & + & rec_angular_vel(2), rec_angular_vel(3), rec_angles(1), rec_angles(2), rec_angles(3), rec_centroid(1), & + & rec_centroid(2), rec_centroid(3) end if end do @@ -1326,16 +1290,18 @@ contains close (iu_out(i)) end do deallocate (iu_out) + end subroutine s_write_ib_state_files !> @brief Extract the volume-fraction interface contour from primitive fields and write the coordinates to the interface data !! file. impure subroutine s_write_intf_data_file(q_prim_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer :: i, j, k, l, cent !< Generic loop iterators - integer :: counter, root !< number of data points extracted to fit shape to SH perturbations - real(wp), allocatable :: x_td(:), y_td(:), x_d1(:), y_d1(:), y_d(:), x_d(:) - real(wp) :: axp, axm, ayp, aym, tgp, euc_d, thres, maxalph_loc, maxalph_glb + integer :: i, j, k, l, cent !< Generic loop iterators + integer :: counter, root !< number of data points extracted to fit shape to SH perturbations + real(wp), allocatable :: x_td(:), y_td(:), x_d1(:), y_d1(:), y_d(:), x_d(:) + real(wp) :: axp, axm, ayp, aym, tgp, euc_d, thres, maxalph_loc, maxalph_glb allocate (x_d1(m*n)) allocate (y_d1(m*n)) @@ -1411,17 +1377,19 @@ contains end if end do end if + end subroutine s_write_intf_data_file !> @brief Compute volume-integrated kinetic, potential, and internal energies and write the energy budget to the energy data !! file. impure subroutine s_write_energy_data_file(q_prim_vf, q_cons_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf, q_cons_vf - real(wp) :: Elk, Egk, Elp, Egint, Vb, Vl, pres_av, Et - real(wp) :: rho, pres, dV, tmp, gamma, pi_inf, MaxMa, MaxMa_glb, maxvel, c, Ma, H, qv - real(wp), dimension(num_vels) :: vel - real(wp), dimension(num_fluids) :: adv - integer :: i, j, k, l, s ! looping indices + real(wp) :: Elk, Egk, Elp, Egint, Vb, Vl, pres_av, Et + real(wp) :: rho, pres, dV, tmp, gamma, pi_inf, MaxMa, MaxMa_glb, maxvel, c, Ma, H, qv + real(wp), dimension(num_vels) :: vel + real(wp), dimension(num_fluids) :: adv + integer :: i, j, k, l, s ! looping indices Egk = 0._wp Elp = 0._wp @@ -1502,24 +1470,21 @@ contains if (proc_rank == 0) then write (251, '(10X, 8F24.8)') Elp, Egint, Elk, Egk, Et, Vb, Vl, MaxMa_glb end if + end subroutine s_write_energy_data_file !> @brief Close the formatted database slave file and, for the root process, the master file. impure subroutine s_close_formatted_database_file() - ! Description: The purpose of this subroutine is to close any formatted - ! database file(s) that may be opened at the time-step that - ! is currently being post-processed. The root process must - ! typically close two files, one associated with the local - ! sub-domain and the other with the entire domain. The non- - ! root process(es) must close one file, which is associated - ! with the local sub-domain. Note that for the Binary data- - ! base format and multidimensional data, the root process - ! only has to close the file associated with the local sub- - ! domain, because one associated with the entire domain is - ! not generated. + + ! Description: The purpose of this subroutine is to close any formatted database file(s) that may be opened at the time-step + ! that is currently being post-processed. The root process must typically close two files, one associated with the local + ! sub-domain and the other with the entire domain. The non- root process(es) must close one file, which is associated with + ! the local sub-domain. Note that for the Binary data- base format and multidimensional data, the root process only has to + ! close the file associated with the local sub- domain, because one associated with the entire domain is not generated. integer :: ierr !< Generic flag used to identify and report database errors ! Silo-HDF5 database format + if (format == 1) then ierr = DBCLOSE(dbfile) if (proc_rank == 0) ierr = DBCLOSE(dbroot) @@ -1529,35 +1494,39 @@ contains close (dbfile) if (n == 0 .and. proc_rank == 0) close (dbroot) end if + end subroutine s_close_formatted_database_file !> @brief Close the interface data file. impure subroutine s_close_intf_data_file() + close (211) + end subroutine s_close_intf_data_file !> @brief Close the energy data file. impure subroutine s_close_energy_data_file() + close (251) + end subroutine s_close_energy_data_file !> @brief Deallocate module arrays and release all data-output resources. impure subroutine s_finalize_data_output_module() + ! Description: Deallocation procedures for the module - ! Deallocating the generic storage employed for the flow variable(s) - ! that were written to the formatted database file(s). Note that the - ! root variable is only deallocated in the case of a 1D computation. + ! Deallocating the generic storage employed for the flow variable(s) that were written to the formatted database file(s). + ! Note that the root variable is only deallocated in the case of a 1D computation. deallocate (q_sf) if (n == 0) deallocate (q_root_sf) if (grid_geometry == 3) then deallocate (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. + ! 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 == 1) then deallocate (spatial_extents) deallocate (data_extents) @@ -1565,5 +1534,7 @@ contains deallocate (hi_offset) deallocate (dims) end if + end subroutine s_finalize_data_output_module + end module m_data_output diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index a3f88626e9..e05364a918 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -5,10 +5,11 @@ !> @brief Computes derived flow quantities (sound speed, vorticity, Schlieren, etc.) from conservative and primitive variables module m_derived_variables - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_variables_conversion implicit none @@ -35,23 +36,22 @@ module m_derived_variables !! non-zero. Note that a similar procedure does not have to be applied to the second dimension since in 1D, the buffer size is !! always zero. integer, private :: flg + contains - !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_derived_variables_module - ! Allocating the gradient magnitude of the density variable provided - ! that numerical Schlieren function is outputted during post-process + + ! Allocating the gradient magnitude of the density variable provided that numerical Schlieren function is outputted during + ! post-process 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)) end if - ! Allocating the variables which will store the coefficients of the - ! centered family of finite-difference schemes. Note that sufficient - ! space is allocated so that the coefficients up to any chosen order - ! of accuracy may be bookkept. However, if higher than fourth-order - ! accuracy coefficients are wanted, the formulae required to compute - ! these coefficients will have to be implemented in the subroutine - ! s_compute_finite_difference_coefficients. + ! Allocating the variables which will store the coefficients of the centered family of finite-difference schemes. Note that + ! sufficient space is allocated so that the coefficients up to any chosen order of accuracy may be bookkept. However, if + ! higher than fourth-order accuracy coefficients are wanted, the formulae required to compute these coefficients will have + ! to be implemented in the subroutine s_compute_finite_difference_coefficients. ! Allocating centered finite-difference coefficients in x-direction if (omega_wrt(2) .or. omega_wrt(3) .or. schlieren_wrt .or. liutex_wrt) then @@ -68,22 +68,23 @@ contains allocate (fd_coeff_z(-fd_number:fd_number, -offset_z%beg:p + offset_z%end)) end if - ! Annotating the dimensionality of the dataset undergoing the post- - ! process. A flag value of 1 indicates that the dataset is 3D, while - ! a flag value of 0 indicates that it is not. + ! Annotating the dimensionality of the dataset undergoing the post- process. A flag value of 1 indicates that the dataset is + ! 3D, while a flag value of 0 indicates that it is not. if (p > 0) then flg = 1 else flg = 0 end if + end subroutine s_initialize_derived_variables_module !> This subroutine receives as input the specific heat ratio function, gamma_sf, and derives from it the specific heat ratio. !! The latter is stored in the derived flow quantity storage variable, q_sf. !! @param q_sf Specific heat ratio subroutine s_derive_specific_heat_ratio(q_sf) + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators ! Computing specific heat ratio from specific heat ratio function @@ -94,6 +95,7 @@ contains end do end do end do + end subroutine s_derive_specific_heat_ratio !> This subroutine admits as inputs the specific heat ratio function and the liquid stiffness function, gamma_sf and pi_inf_sf, @@ -101,12 +103,13 @@ contains !! storage variable, q_sf. !! @param q_sf Liquid stiffness subroutine s_derive_liquid_stiffness(q_sf) + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators - ! Calculating the values of the liquid stiffness from those of the - ! specific heat ratio function and the liquid stiffness function + ! Calculating the values of the liquid stiffness from those of the specific heat ratio function and the liquid stiffness + ! function do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end @@ -114,37 +117,39 @@ contains end do end do end do + end subroutine s_derive_liquid_stiffness !> This subroutine admits as inputs the primitive variables, the density, the specific heat ratio function and liquid stiffness !! function. It then computes from those variables the values of the speed of sound, which are stored in the derived flow !! quantity storage variable, q_sf. - !! @param q_prim_vf Primitive variables - !! @param q_sf Speed of sound + !! @param q_prim_vf Primitive variables + !! @param q_sf Speed of sound subroutine s_derive_sound_speed(q_prim_vf, q_sf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf integer :: i, j, k !< Generic loop iterators ! Fluid bulk modulus for alternate sound speed real(wp) :: blkmod1, blkmod2 - ! Computing speed of sound values from those of pressure, density, - ! specific heat ratio function and the liquid stiffness function + ! Computing speed of sound values from those of pressure, density, specific heat ratio function and the liquid stiffness + ! function do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end ! Compute mixture sound speed if (alt_soundspeed .neqv. .true.) then q_sf(i, j, k) = (((gamma_sf(i, j, k) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_inf_sf(i, j, & - & k))/(gamma_sf(i, j, k)*rho_sf(i, j, k))) + & k))/(gamma_sf(i, j, k)*rho_sf(i, j, k))) else blkmod1 = ((gammas(1) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_infs(2))/gammas(2) q_sf(i, j, k) = (1._wp/(rho_sf(i, j, k)*(q_prim_vf(adv_idx%beg)%sf(i, j, & - & k)/blkmod1 + (1._wp - q_prim_vf(adv_idx%beg)%sf(i, j, k))/blkmod2))) + & k)/blkmod1 + (1._wp - q_prim_vf(adv_idx%beg)%sf(i, j, k))/blkmod2))) end if if (mixture_err .and. q_sf(i, j, k) < 0._wp) then @@ -155,6 +160,7 @@ contains end do end do end do + end subroutine s_derive_sound_speed !> This subroutine derives the flux_limiter at cell boundary i+1/2. This is an approximation because the velocity used to @@ -164,11 +170,12 @@ contains !! @param q_prim_vf Primitive variables !! @param q_sf Flux limiter subroutine s_derive_flux_limiter(i, q_prim_vf, q_sf) + integer, intent(in) :: i type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf real(wp) :: top, bottom, slope !< Flux limiter calcs integer :: j, k, l !< Generic loop iterators @@ -206,10 +213,8 @@ contains if (f_approx_equal(top, bottom)) then slope = 1._wp - ! ELSEIF((top == 0._wp .AND. bottom /= 0._wp) & - ! .OR. & - ! (bottom == 0._wp .AND. top /= 0._wp)) THEN - ! slope = 0._wp + ! ELSEIF((top == 0._wp .AND. bottom /= 0._wp) & .OR. & (bottom == 0._wp .AND. top /= 0._wp)) THEN slope = + ! 0._wp else slope = (top*bottom)/(bottom**2._wp + 1.e-16_wp) end if @@ -233,6 +238,7 @@ contains end do end do end do + end subroutine s_derive_flux_limiter !> Computes the solution to the linear system Ax=b w/ sol = x @@ -241,6 +247,7 @@ contains !! @param sol Solution !! @param ndim Problem size subroutine s_solve_linear_system(A, b, sol, ndim) + integer, intent(in) :: ndim real(wp), dimension(ndim, ndim), intent(inout) :: A real(wp), dimension(ndim), intent(inout) :: b @@ -250,8 +257,8 @@ contains integer :: i, j, k - ! Solve linear system using own linear solver (Thomson/Darter/Comet/Stampede) - ! Forward elimination + ! Solve linear system using own linear solver (Thomson/Darter/Comet/Stampede) Forward elimination + do i = 1, ndim ! Pivoting j = i - 1 + maxloc(abs(A(i:ndim, i)), 1) @@ -277,6 +284,7 @@ contains sol(i) = sol(i) - A(i, k)*sol(k) end do end do + end subroutine s_solve_linear_system !> This subroutine receives as inputs the indicator of the component of the vorticity that should be outputted and the primitive @@ -286,11 +294,12 @@ contains !! @param q_prim_vf Primitive variables !! @param q_sf Vorticity component subroutine s_derive_vorticity_component(i, q_prim_vf, q_sf) + integer, intent(in) :: i type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf integer :: j, k, l, r !< Generic loop iterators ! Computing the vorticity component in the x-coordinate direction @@ -303,11 +312,11 @@ 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(mom_idx%end)%sf(j, r + k, l) - fd_coeff_z(r, & - & l)*q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l)) + & k)*y_cc(r + k)*q_prim_vf(mom_idx%end)%sf(j, r + k, l) - fd_coeff_z(r, & + & l)*q_prim_vf(mom_idx%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(mom_idx%end)%sf(j, r + k, & - & l) - fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l) + & l) - fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + 1)%sf(j, k, r + l) end if end do end do @@ -324,10 +333,10 @@ 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(mom_idx%beg)%sf(j, k, & - & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%end)%sf(r + j, k, l) + & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%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(mom_idx%beg)%sf(j, k, & - & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%end)%sf(r + j, k, l) + & r + l) - fd_coeff_x(r, j)*q_prim_vf(mom_idx%end)%sf(r + j, k, l) end if end do end do @@ -343,12 +352,13 @@ contains do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_x(r, j)*q_prim_vf(mom_idx%beg + 1)%sf(r + j, k, & - & l) - fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg)%sf(j, r + k, l) + & l) - fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg)%sf(j, r + k, l) end do end do end do end do end if + end subroutine s_derive_vorticity_component !> This subroutine gets as inputs the primitive variables. From those inputs, it proceeds to calculate the value of the Q_M @@ -356,10 +366,11 @@ contains !! @param q_prim_vf Primitive variables !! @param q_sf Q_M subroutine s_derive_qm(q_prim_vf, q_sf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf real(wp), dimension(1:3, 1:3) :: q_jacobian_sf, S, S2, O, O2 real(wp) :: trS, Q, IIS @@ -374,13 +385,13 @@ contains do jj = 1, 3 ! d()/dx q_jacobian_sf(jj, 1) = q_jacobian_sf(jj, 1) + fd_coeff_x(r, & - & j)*q_prim_vf(mom_idx%beg + jj - 1)%sf(r + j, k, l) + & j)*q_prim_vf(mom_idx%beg + jj - 1)%sf(r + j, k, l) ! d()/dy q_jacobian_sf(jj, 2) = q_jacobian_sf(jj, 2) + fd_coeff_y(r, k)*q_prim_vf(mom_idx%beg + jj - 1)%sf(j, & - & r + k, l) + & r + k, l) ! d()/dz q_jacobian_sf(jj, 3) = q_jacobian_sf(jj, 3) + fd_coeff_z(r, l)*q_prim_vf(mom_idx%beg + jj - 1)%sf(j, & - & k, r + l) + & k, r + l) end do end do @@ -408,21 +419,24 @@ contains end do end do end do + end subroutine s_derive_qm !> This subroutine gets as inputs the primitive variables. From those inputs, it proceeds to calculate the Liutex vector and its !! magnitude based on Xu et al. (2019). !! @param q_prim_vf Primitive variables impure subroutine s_derive_liutex(q_prim_vf, liutex_mag, liutex_axis) + integer, parameter :: nm = 3 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !> Liutex magnitude + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(out) :: liutex_mag + & intent(out) :: liutex_mag !> Liutex rigid rotation axis real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, nm), & - & intent(out) :: liutex_axis + & intent(out) :: liutex_axis character, parameter :: ivl = 'N' !< compute left eigenvectors character, parameter :: ivr = 'V' !< compute right eigenvectors real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor @@ -482,10 +496,9 @@ contains ! Compute vorticity projected on the eigenvector omega_proj = (vgt(3, 2) - vgt(2, 3))*eigvec(1) + (vgt(1, 3) - vgt(3, 1))*eigvec(2) + (vgt(2, 1) - vgt(1, & - & 2))*eigvec(3) + & 2))*eigvec(3) - ! As eigenvector can have +/- signs, we can choose the sign - ! so that omega_proj is positive + ! As eigenvector can have +/- signs, we can choose the sign so that omega_proj is positive if (omega_proj < 0._wp) then eigvec = -eigvec omega_proj = -omega_proj @@ -509,6 +522,7 @@ contains end do end do end do + end subroutine s_derive_liutex !> This subroutine gets as inputs the conservative variables and density. From those inputs, it proceeds to calculate the values @@ -516,10 +530,11 @@ contains !! @param q_cons_vf Conservative variables !! @param q_sf Numerical Schlieren function impure subroutine s_derive_numerical_schlieren_function(q_cons_vf, q_sf) + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & - & intent(inout) :: q_sf + & intent(inout) :: q_sf real(wp) :: drho_dx, drho_dy, drho_dz !< Spatial derivatives of the density in the x-, y- and z-directions !> Maximum value of the gradient magnitude (gm) of the density field in entire computational domain and not just the local @@ -567,31 +582,25 @@ contains end do end if - ! Up until now, only the dot product of the gradient of the density - ! field has been calculated and stored in the gradient magnitude of - ! density variable. So now we proceed to take the square-root as to - ! complete the desired calculation. + ! Up until now, only the dot product of the gradient of the density field has been calculated and stored in the gradient + ! magnitude of density variable. So now we proceed to take the square-root as to complete the desired calculation. gm_rho_sf = sqrt(gm_rho_sf) - ! Determining the local maximum of the gradient magnitude of density - ! and bookkeeping the result, along with rank of the local processor + ! Determining the local maximum of the gradient magnitude of density and bookkeeping the result, along with rank of the + ! local processor gm_rho_max = (/maxval(gm_rho_sf), real(proc_rank, wp)/) - ! Comparing the local maximum gradient magnitude of the density on - ! this processor to the those computed on the remaining processors. - ! This allows for the global maximum to be computed and the rank of - ! the processor on which it has occurred to be recorded. + ! Comparing the local maximum gradient magnitude of the density on this processor to the those computed on the remaining + ! processors. This allows for the global maximum to be computed and the rank of the processor on which it has occurred to be + ! recorded. if (num_procs > 1) call s_mpi_reduce_maxloc(gm_rho_max) ! Computing Numerical Schlieren Function - ! The form of the numerical Schlieren function depends on the choice - ! of the multicomponent flow model. For the gamma/pi_inf model, the - ! exponential of the negative, normalized, gradient magnitude of the - ! density is computed. For the volume fraction model, the amplitude - ! of the exponential's inside is also modulated with respect to the - ! identity of the fluid in which the function is evaluated. For more - ! information, refer to Marquina and Mulet (2003). + ! The form of the numerical Schlieren function depends on the choice of the multicomponent flow model. For the gamma/pi_inf + ! model, the exponential of the negative, normalized, gradient magnitude of the density is computed. For the volume fraction + ! model, the amplitude of the exponential's inside is also modulated with respect to the identity of the fluid in which the + ! function is evaluated. For more information, refer to Marquina and Mulet (2003). if (model_eqns == 1) then ! Gamma/pi_inf model q_sf = -gm_rho_sf/gm_rho_max(1) @@ -603,30 +612,32 @@ contains do i = 1, adv_idx%end - E_idx q_sf(j, k, l) = q_sf(j, k, l) - schlieren_alpha(i)*q_cons_vf(i + E_idx)%sf(j, k, l)*gm_rho_sf(j, k, & - & l)/gm_rho_max(1) + & l)/gm_rho_max(1) end do end do end do end do end if - ! Up until now, only the inside of the exponential of the numerical - ! Schlieren function has been evaluated and stored. Then, to finish - ! the computation, the exponential of the inside quantity is taken. + ! Up until now, only the inside of the exponential of the numerical Schlieren function has been evaluated and stored. Then, + ! to finish the computation, the exponential of the inside quantity is taken. q_sf = exp(q_sf) + end subroutine s_derive_numerical_schlieren_function !> Deallocation procedures for the module impure subroutine s_finalize_derived_variables_module - ! Deallocating the variable containing the gradient magnitude of the - ! density field provided that the numerical Schlieren function was - ! was outputted during the post-process + + ! 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) - ! Deallocating the variables that might have been used to bookkeep - ! the finite-difference coefficients in the x-, y- and z-directions + ! 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) + end subroutine s_finalize_derived_variables_module + end module m_derived_variables diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index 2518ab1505..69f1bcf49e 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -6,12 +6,13 @@ !> @brief Global parameters for the post-process: domain geometry, equation of state, and output database settings module m_global_parameters + #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif use m_derived_types !< Definitions of the derived types - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_thermochem, only: num_species, species_names implicit none @@ -81,9 +82,8 @@ module m_global_parameters integer :: n_start !> @} - ! NOTE: The variables m_root, x_root_cb and x_root_cc contain the grid data - ! of the defragmented computational domain. They are only used in 1D. For - ! serial simulations, they are equal to m, x_cb and x_cc, respectively. + ! NOTE: The variables m_root, x_root_cb and x_root_cc contain the grid data of the defragmented computational domain. They are + ! only used in 1D. For serial simulations, they are equal to m, x_cb and x_cc, respectively. !> @name Simulation Algorithm Parameters !> @{ @@ -135,13 +135,11 @@ module m_global_parameters integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD !> @} - ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). - ! Stands for "InDices With BUFFer". + ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). Stands for "InDices With BUFFer". type(int_bounds_info) :: idwint(1:3) - ! Cell Indices for the entire (local) domain. In simulation, this includes - ! the buffer region. idwbuff and idwint are the same otherwise. - ! Stands for "InDices With BUFFer". + ! Cell Indices for the entire (local) domain. In simulation, this includes the buffer region. idwbuff and idwint are the same + ! otherwise. Stands for "InDices With BUFFer". type(int_bounds_info) :: idwbuff(1:3) integer :: num_bc_patches logical :: bc_io @@ -271,29 +269,28 @@ module m_global_parameters type(chemistry_parameters) :: chem_params !> @name Bubble modeling variables and parameters !> @{ - integer :: nb - real(wp) :: Eu, Ca, Web, Re_inv + integer :: nb + real(wp) :: Eu, Ca, Web, Re_inv real(wp), dimension(:), allocatable :: weight, R0 - logical :: bubbles_euler - logical :: qbmm - logical :: polytropic - logical :: polydisperse - logical :: adv_n - integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer - real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl - real(wp) :: gam_m + logical :: bubbles_euler + logical :: qbmm + logical :: polytropic + logical :: polydisperse + logical :: adv_n + integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer + real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl + real(wp) :: gam_m real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g real(wp), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN - real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g - real(wp) :: G - real(wp) :: poly_sigma - real(wp) :: sigR - integer :: nmom + real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g + real(wp) :: G + real(wp) :: poly_sigma + real(wp) :: sigR + integer :: nmom !> @} !> @name surface tension coefficient !> @{ - real(wp) :: sigma logical :: surface_tension !> @} @@ -317,13 +314,16 @@ module m_global_parameters real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) real(wp) :: wall_time, wall_time_avg !< Wall time measurements + contains !> Assigns default values to user inputs prior to reading them in. This allows for an easier consistency check of these !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs + integer :: i !< Generic loop iterator ! Logistics + case_dir = '.' ! Computational domain parameters @@ -510,13 +510,16 @@ contains ! MHD Bx0 = dflt_real + end subroutine s_assign_default_values_to_user_inputs - !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_global_parameters_module + integer :: i, j, fac ! Setting m_root equal to m in the case of a 1D serial simulation + if (n == 0) m_root = m_glb ! Gamma/Pi_inf Model @@ -524,9 +527,8 @@ contains ! Setting number of fluids num_fluids = 1 - ! Annotating structure of the state and flux vectors belonging - ! to the system of equations defined by the selected number of - ! spatial dimensions and the gamma/pi_inf model + ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number + ! of spatial dimensions and the gamma/pi_inf model cont_idx%beg = 1 cont_idx%end = cont_idx%beg mom_idx%beg = cont_idx%end + 1 @@ -540,9 +542,8 @@ contains ! Volume Fraction Model (5-equation model) else if (model_eqns == 2) then - ! Annotating structure of the state and flux vectors belonging - ! to the system of equations defined by the selected number of - ! spatial dimensions and the volume fraction model + ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number + ! of spatial dimensions and the volume fraction model cont_idx%beg = 1 cont_idx%end = num_fluids mom_idx%beg = cont_idx%end + 1 @@ -550,17 +551,14 @@ contains E_idx = mom_idx%end + 1 if (igr) then - ! Volume fractions are stored in the indices immediately following - ! the energy equation. IGR tracks a total of (N-1) volume fractions - ! for N fluids, hence the "-1" in adv_idx%end. If num_fluids = 1 - ! then adv_idx%end < adv_idx%beg, which skips all loops over the - ! volume fractions since there is no volume fraction to track + ! Volume fractions are stored in the indices immediately following the energy equation. IGR tracks a total of (N-1) + ! volume fractions for N fluids, hence the "-1" in adv_idx%end. If num_fluids = 1 then adv_idx%end < adv_idx%beg, + ! which skips all loops over the volume fractions since there is no volume fraction to track adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 adv_idx%end = E_idx + num_fluids - 1 else - ! Volume fractions are stored in the indices immediately following - ! the energy equation. WENO/MUSCL + Riemann tracks a total of (N) - ! volume fractions for N fluids, hence the lack of "-1" in adv_idx%end + ! Volume fractions are stored in the indices immediately following the energy equation. WENO/MUSCL + Riemann tracks + ! a total of (N) volume fractions for N fluids, hence the lack of "-1" in adv_idx%end adv_idx%beg = E_idx + 1 adv_idx%end = E_idx + num_fluids end if @@ -643,9 +641,8 @@ contains ! Volume Fraction Model (6-equation model) else if (model_eqns == 3) then - ! Annotating structure of the state and flux vectors belonging - ! to the system of equations defined by the selected number of - ! spatial dimensions and the volume fraction model + ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number + ! of spatial dimensions and the volume fraction model cont_idx%beg = 1 cont_idx%end = num_fluids mom_idx%beg = cont_idx%end + 1 @@ -735,9 +732,7 @@ contains shear_BC_flip_indices(1, 1:2) = shear_indices((/1, 2/)) shear_BC_flip_indices(2, 1:2) = shear_indices((/1, 3/)) shear_BC_flip_indices(3, 1:2) = shear_indices((/2, 3/)) - ! x-dir: flip tau_xy and tau_xz - ! y-dir: flip tau_xy and tau_yz - ! z-dir: flip tau_xz and tau_yz + ! x-dir: flip tau_xy and tau_xz y-dir: flip tau_xy and tau_yz z-dir: flip tau_xz and tau_yz end if end if @@ -833,11 +828,9 @@ contains if (ib) allocate (MPI_IO_IB_DATA%var%sf(0:m, 0:n, 0:p)) #endif - ! Size of the ghost zone layer is non-zero only when post-processing - ! the raw simulation data of a parallel multidimensional computation - ! in the Silo-HDF5 format. If this is the case, one must also verify - ! whether the raw simulation data is 2D or 3D. In the 2D case, size - ! of the z-coordinate direction ghost zone layer must be zeroed out. + ! Size of the ghost zone layer is non-zero only when post-processing the raw simulation data of a parallel multidimensional + ! computation in the Silo-HDF5 format. If this is the case, one must also verify whether the raw simulation data is 2D or + ! 3D. In the 2D case, size of the z-coordinate direction ghost zone layer must be zeroed out. if (num_procs == 1 .or. format /= 1) then offset_x%beg = 0 offset_x%end = 0 @@ -855,12 +848,9 @@ contains offset_z%end = 0 end if - ! Determining the finite-difference number and the buffer size. Note - ! that the size of the buffer is unrelated to the order of the WENO - ! scheme. Rather, it is directly dependent on maximum size of ghost - ! zone layers and possibly the order of the finite difference scheme - ! used for the computation of vorticity and/or numerical Schlieren - ! function. + ! Determining the finite-difference number and the buffer size. Note that the size of the buffer is unrelated to the order + ! of the WENO scheme. Rather, it is directly dependent on maximum size of ghost zone layers and possibly the order of the + ! finite difference scheme used for the computation of vorticity and/or numerical Schlieren function. buff_size = max(offset_x%beg, offset_x%end, offset_y%beg, offset_y%end, offset_z%beg, offset_z%end) if (any(omega_wrt) .or. schlieren_wrt .or. qm_wrt .or. liutex_wrt) then @@ -900,8 +890,8 @@ contains allocate (dz(-buff_size:p + buff_size)) end if - ! Allocating the grid variables, only used for the 1D simulations, - ! and containing the defragmented computational domain grid data + ! Allocating the grid variables, only used for the 1D simulations, and containing the defragmented computational domain + ! grid data else allocate (x_root_cb(-1:m_root)) @@ -921,10 +911,12 @@ contains else ! Fully 3D cylindrical grid grid_geometry = 3 end if + end subroutine s_initialize_global_parameters_module !> Subroutine to initialize parallel infrastructure impure subroutine s_initialize_parallel_io + #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors #endif @@ -949,20 +941,21 @@ contains call MPI_INFO_CREATE(mpi_info_int, ierr) call MPI_INFO_SET(mpi_info_int, 'romio_ds_write', 'disable', ierr) - ! Option for UNIX file system (Hooke/Thomson) - ! WRITE(mpiiofs, '(A)') '/ufs_' - ! mpiiofs = TRIM(mpiiofs) - ! mpi_info_int = MPI_INFO_NULL + ! Option for UNIX file system (Hooke/Thomson) WRITE(mpiiofs, '(A)') '/ufs_' mpiiofs = TRIM(mpiiofs) mpi_info_int = + ! MPI_INFO_NULL allocate (start_idx(1:num_dims)) #endif + end subroutine s_initialize_parallel_io !> Deallocation procedures for the module impure subroutine s_finalize_global_parameters_module + integer :: i ! Deallocating the grid variables for the x-coordinate direction + deallocate (x_cc, x_cb, dx) ! Deallocating grid variables for the y- and z-coordinate directions @@ -972,8 +965,8 @@ contains deallocate (z_cc, z_cb, dz) end if else - ! Deallocating the grid variables, only used for the 1D simulations, - ! and containing the defragmented computational domain grid data + ! Deallocating the grid variables, only used for the 1D simulations, and containing the defragmented computational + ! domain grid data deallocate (x_root_cb, x_root_cc) end if @@ -995,5 +988,7 @@ contains if (ib) MPI_IO_IB_DATA%var%sf => null() #endif + end subroutine s_finalize_global_parameters_module + end module m_global_parameters diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index c15e25f0d4..39d71967d0 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -4,11 +4,12 @@ !> @brief MPI gather and scatter operations for distributing post-process grid and flow-variable data module m_mpi_proxy + #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code use m_mpi_common use ieee_arithmetic @@ -21,18 +22,20 @@ module m_mpi_proxy integer, allocatable, dimension(:) :: recvcounts integer, allocatable, dimension(:) :: displs !> @} + contains - !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_mpi_proxy_module + #ifdef MFC_MPI integer :: i !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors - ! Allocating and configuring the receive counts and the displacement - ! vector variables used in variable-gather communication procedures. - ! Note that these are only needed for either multidimensional runs - ! that utilize the Silo database file format or for 1D simulations. + ! Allocating and configuring the receive counts and the displacement vector variables used in variable-gather communication + ! procedures. Note that these are only needed for either multidimensional runs that utilize the Silo database file format or + ! for 1D simulations. + if ((format == 1 .and. n > 0) .or. n == 0) then allocate (recvcounts(0:num_procs - 1)) allocate (displs(0:num_procs - 1)) @@ -52,15 +55,18 @@ contains end if end if #endif + end subroutine s_initialize_mpi_proxy_module !> Since only processor with rank 0 is in charge of reading and checking the consistency of the user provided inputs, these are !! not available to the remaining processors. This subroutine is then in charge of broadcasting the required information. impure subroutine s_mpi_bcast_user_inputs + #ifdef MFC_MPI integer :: i !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors ! Logistics + call MPI_BCAST(case_dir, len(case_dir), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) #:for VAR in [ 'm', 'n', 'p', 'm_glb', 'n_glb', 'p_glb', & @@ -130,6 +136,7 @@ contains #:endfor call MPI_BCAST(schlieren_alpha(1), num_fluids_max, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_bcast_user_inputs !> This subroutine gathers the Silo database metadata for the spatial extents in order to boost the performance of the @@ -137,6 +144,7 @@ contains ! ! @param spatial_extents Spatial extents for each processor's sub-domain. First dimension corresponds to the minimum and ! maximum values, respectively, while the second dimension corresponds to the processor rank. impure subroutine s_mpi_gather_spatial_extents(spatial_extents) + real(wp), dimension(1:, 0:), intent(inout) :: spatial_extents #ifdef MFC_MPI @@ -144,55 +152,56 @@ contains real(wp) :: ext_temp(0:num_procs - 1) ! Simulation is 3D + if (p > 0) then if (grid_geometry == 3) then ! Minimum spatial extent in the r-direction call MPI_GATHERV(minval(y_cb), 1, mpi_p, spatial_extents(1, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Minimum spatial extent in the theta-direction call MPI_GATHERV(minval(z_cb), 1, mpi_p, spatial_extents(2, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Minimum spatial extent in the z-direction call MPI_GATHERV(minval(x_cb), 1, mpi_p, spatial_extents(3, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the r-direction call MPI_GATHERV(maxval(y_cb), 1, mpi_p, spatial_extents(4, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the theta-direction call MPI_GATHERV(maxval(z_cb), 1, mpi_p, spatial_extents(5, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the z-direction call MPI_GATHERV(maxval(x_cb), 1, mpi_p, spatial_extents(6, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) else ! Minimum spatial extent in the x-direction call MPI_GATHERV(minval(x_cb), 1, mpi_p, spatial_extents(1, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Minimum spatial extent in the y-direction call MPI_GATHERV(minval(y_cb), 1, mpi_p, spatial_extents(2, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Minimum spatial extent in the z-direction call MPI_GATHERV(minval(z_cb), 1, mpi_p, spatial_extents(3, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the x-direction call MPI_GATHERV(maxval(x_cb), 1, mpi_p, spatial_extents(4, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the y-direction call MPI_GATHERV(maxval(y_cb), 1, mpi_p, spatial_extents(5, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) ! Maximum spatial extent in the z-direction call MPI_GATHERV(maxval(z_cb), 1, mpi_p, spatial_extents(6, 0), recvcounts, 6*displs, mpi_p, 0, MPI_COMM_WORLD, & - & ierr) + & ierr) end if ! Simulation is 2D else if (n > 0) then @@ -210,8 +219,8 @@ contains ! Simulation is 1D else - ! For 1D, recvcounts/displs are sized for grid defragmentation - ! (m+1 per rank), not for scalar gathers. Use MPI_GATHER instead. + ! For 1D, recvcounts/displs are sized for grid defragmentation (m+1 per rank), not for scalar gathers. Use MPI_GATHER + ! instead. ! Minimum spatial extent in the x-direction call MPI_GATHER(minval(x_cb), 1, mpi_p, ext_temp, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) @@ -222,14 +231,17 @@ contains if (proc_rank == 0) spatial_extents(2,:) = ext_temp end if #endif + end subroutine s_mpi_gather_spatial_extents !> This subroutine collects the sub-domain cell-boundary or cell-center locations data from all of the processors and puts back !! together the grid of the entire computational domain on the rank 0 processor. This is only done for 1D simulations. impure subroutine s_mpi_defragment_1d_grid_variable + #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors ! Silo-HDF5 database format + if (format == 1) then call MPI_GATHERV(x_cc(0), m + 1, mpi_p, x_root_cc(0), recvcounts, displs, mpi_p, 0, MPI_COMM_WORLD, ierr) @@ -241,6 +253,7 @@ contains if (proc_rank == 0) x_root_cb(-1) = x_cb(-1) end if #endif + end subroutine s_mpi_defragment_1d_grid_variable !> This subroutine gathers the Silo database metadata for the flow variable's extents as to boost performance of the @@ -249,6 +262,7 @@ contains ! ! @param data_extents The flow variable extents on each of the processor's sub-domain. First dimension of array corresponds to ! the former's minimum and maximum values, respectively, while second dimension corresponds to each processor's rank. impure subroutine s_mpi_gather_data_extents(q_sf, data_extents) + real(wp), dimension(:,:,:), intent(in) :: q_sf real(wp), dimension(1:2, 0:num_procs - 1), intent(inout) :: data_extents @@ -257,15 +271,14 @@ contains real(wp) :: ext_temp(0:num_procs - 1) if (n > 0) then - ! Multi-D: recvcounts = 1, so strided MPI_GATHERV works correctly - ! Minimum flow variable extent + ! Multi-D: recvcounts = 1, so strided MPI_GATHERV works correctly Minimum flow variable extent call MPI_GATHERV(minval(q_sf), 1, mpi_p, data_extents(1, 0), recvcounts, 2*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) ! Maximum flow variable extent call MPI_GATHERV(maxval(q_sf), 1, mpi_p, data_extents(2, 0), recvcounts, 2*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) else - ! 1D: recvcounts/displs are sized for grid defragmentation - ! (m+1 per rank), not for scalar gathers. Use MPI_GATHER instead. + ! 1D: recvcounts/displs are sized for grid defragmentation (m+1 per rank), not for scalar gathers. Use MPI_GATHER + ! instead. ! Minimum flow variable extent call MPI_GATHER(minval(q_sf), 1, mpi_p, ext_temp, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) @@ -276,6 +289,7 @@ contains if (proc_rank == 0) data_extents(2,:) = ext_temp end if #endif + end subroutine s_mpi_gather_data_extents !> This subroutine gathers the sub-domain flow variable data from all of the processors and puts it back together for the entire @@ -283,28 +297,32 @@ contains !! @param q_sf Flow variable defined on a single computational sub-domain !! @param q_root_sf Flow variable defined on the entire computational domain impure subroutine s_mpi_defragment_1d_flow_variable(q_sf, q_root_sf) + real(wp), dimension(0:m), intent(in) :: q_sf real(wp), dimension(0:m), intent(inout) :: q_root_sf #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Gathering the sub-domain flow variable data from all the processes - ! and putting it back together for the entire computational domain - ! on the process with rank 0 + ! Gathering the sub-domain flow variable data from all the processes and putting it back together for the entire + ! computational domain on the process with rank 0 + call MPI_GATHERV(q_sf(0), m + 1, mpi_p, q_root_sf(0), recvcounts, displs, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_defragment_1d_flow_variable !> Deallocation procedures for the module impure subroutine s_finalize_mpi_proxy_module + #ifdef MFC_MPI - ! Deallocating the receive counts and the displacement vector - ! variables used in variable-gather communication procedures + ! Deallocating the receive counts and the displacement vector variables used in variable-gather communication procedures if ((format == 1 .and. n > 0) .or. n == 0) then deallocate (recvcounts) deallocate (displs) end if #endif + end subroutine s_finalize_mpi_proxy_module + end module m_mpi_proxy diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 2376e95585..327d89dfac 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -7,19 +7,20 @@ !> @brief Reads and validates user inputs, allocates variables, and configures MPI decomposition and I/O for post-processing module m_start_up + ! Dependencies use, intrinsic :: iso_c_binding - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_mpi_common !< Common MPI subroutines - use m_boundary_common !< Common boundary conditions subroutines + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_common !< Common MPI subroutines + use m_boundary_common !< Common boundary conditions subroutines use m_variables_conversion !< Subroutines to change the state variables from one form to another - use m_data_input !< Procedures reading raw simulation data to fill the conservative, primitive and grid variables - use m_data_output !< Procedures that write the grid and chosen flow variable(s) to the formatted database file(s) - use m_derived_variables !< Procedures used to compute quantities derived from the conservative and primitive variables + use m_data_input !< Procedures reading raw simulation data to fill the conservative, primitive and grid variables + use m_data_output !< Procedures that write the grid and chosen flow variable(s) to the formatted database file(s) + use m_derived_variables !< Procedures used to compute quantities derived from the conservative and primitive variables use m_helper use m_compile_specific use m_checker_common @@ -48,20 +49,23 @@ module m_start_up integer, dimension(3) :: cart3d_coords integer, dimension(2) :: cart2d12_coords, cart2d13_coords integer :: proc_rank12, proc_rank13 + contains !> Reads the configuration file post_process.inp, in order to populate parameters in module m_global_parameters.f90 with the !! user provided inputs impure subroutine s_read_input_file + character(LEN=name_len) :: file_loc !< Generic string used to store the address of a particular file !> Generic logical used for the purpose of asserting whether a file is or is not present in the designated location logical :: file_check integer :: iostatus - !! Integer to check iostat of file read + !! Integer to check iostat of file read character(len=1000) :: line ! Namelist for all of the parameters to be inputted by the user + namelist /user_inputs/ case_dir, m, n, p, t_step_start, t_step_stop, t_step_save, model_eqns, num_fluids, mpp_lim, & & weno_order, bc_x, bc_y, bc_z, fluid_pp, bub_pp, format, precision, output_partial_domain, x_output, y_output, & & z_output, hypoelasticity, G, mhd, chem_wrt_Y, chem_wrt_T, avg_state, alpha_rho_wrt, rho_wrt, mom_wrt, vel_wrt, & @@ -79,8 +83,7 @@ contains file_loc = 'post_process.inp' inquire (FILE=trim(file_loc), EXIST=file_check) - ! Checking whether the input file is there. If it is, the input file - ! is read. If not, the program is terminated. + ! Checking whether the input file is there. If it is, the input file is read. If not, the program is terminated. if (file_check) then open (1, FILE=trim(file_loc), form='formatted', STATUS='old', ACTION='read') read (1, NML=user_inputs, iostat=iostatus) @@ -117,14 +120,17 @@ contains else call s_mpi_abort('File post_process.inp is missing. Exiting.') end if + end subroutine s_read_input_file !> Checking that the user inputs make sense, i.e. that the individual choices are compatible with the code's options and that !! the combination of these choices results into a valid configuration for the post-process impure subroutine s_check_input_file + character(LEN=len_trim(case_dir)) :: file_loc !< Generic string used to store the address of a particular file logical :: dir_check !< Logical variable used to test the existence of folders ! Checking the existence of the case folder + case_dir = adjustl(case_dir) file_loc = trim(case_dir) // '/.' @@ -138,15 +144,18 @@ contains call s_check_inputs_common() call s_check_inputs() + end subroutine s_check_input_file !> @brief Load grid and conservative data for a time step, fill ghost-cell buffers, and convert to primitive variables. impure subroutine s_perform_time_step(t_step) + integer, intent(inout) :: t_step + if (proc_rank == 0) then if (cfl_dt) then print '(" [", I3, "%] Saving ", I8, " of ", I0, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', & - & int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), t_step, n_save, wall_time_avg, wall_time + & int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), t_step, n_save, wall_time_avg, wall_time else print '(" [", I3, "%] Saving ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), (t_step - t_step_start)/t_step_save + 1, (t_step_stop - t_step_start)/t_step_save + 1, t_step, wall_time_avg, wall_time end if @@ -166,18 +175,21 @@ contains ! Converting the conservative variables to the primitive ones call s_convert_conservative_to_primitive_variables(q_cons_vf, q_T_sf, q_prim_vf, idwbuff) + end subroutine s_perform_time_step !> @brief Derive requested flow quantities from primitive variables and write them to the formatted database files. impure subroutine s_save_data(t_step, varname, pres, c, H) + integer, intent(inout) :: t_step character(LEN=name_len), intent(inout) :: varname real(wp), intent(inout) :: pres, c, H real(wp) :: theta1, theta2 + real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, & - & -offset_z%beg:p + offset_z%end) :: liutex_mag + & -offset_z%beg:p + offset_z%end) :: liutex_mag real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, & - & 3) :: liutex_axis + & 3) :: liutex_axis integer :: i, j, k, l, kx, ky, kz, kf, j_glb, k_glb, l_glb real(wp) :: En_tot character(50) :: filename, dirname @@ -267,8 +279,7 @@ contains end if 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 + ! 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) write (varname, '(A)') 'D' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -371,7 +382,7 @@ contains do k = 0, n do j = 0, m data_cmplx(j + 1, k + 1, l + 1) = cmplx(q_cons_vf(mom_idx%beg + 1)%sf(j, k, l)/q_cons_vf(1)%sf(j, k, l), & - & 0._wp) + & 0._wp) end do end do end do @@ -384,7 +395,7 @@ contains do k = 0, n do j = 0, m data_cmplx(j + 1, k + 1, l + 1) = cmplx(q_cons_vf(mom_idx%beg + 2)%sf(j, k, l)/q_cons_vf(1)%sf(j, k, l), & - & 0._wp) + & 0._wp) end do end do end do @@ -621,7 +632,7 @@ contains H = ((gamma_sf(i, j, k) + 1._wp)*pres + pi_inf_sf(i, j, k) + qv_sf(i, j, k))/rho_sf(i, j, k) 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)) + & 0._wp, 0._wp, c, qv_sf(i, j, k)) q_sf(i, j, k) = c end do @@ -648,7 +659,7 @@ contains 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)) + & -offset_z%beg:p + offset_z%end)) varname = 'ib_markers' call s_write_variable_to_formatted_database_file(varname, t_step) end if @@ -763,7 +774,7 @@ 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) + & -offset_z%beg:p + offset_z%end) write (varname, '(A)') 'voidFraction' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -779,10 +790,12 @@ contains ! Closing the formatted database file call s_close_formatted_database_file() + end subroutine s_save_data !> @brief Transpose 3-D complex data from x-pencil to y-pencil layout via MPI_Alltoall. subroutine s_mpi_transpose_x2y + complex(c_double_complex), allocatable :: sendbuf(:), recvbuf(:) integer :: dest_rank, src_rank integer :: i, j, k, l @@ -797,21 +810,21 @@ contains do k = 1, Nyloc do j = 1, Nxloc sendbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + dest_rank*Nxloc*Nyloc*Nzloc) = data_cmplx(j & - & + dest_rank*Nxloc, k, l) + & + dest_rank*Nxloc, k, l) end do end do end do end do call MPI_Alltoall(sendbuf, Nxloc*Nyloc*Nzloc, MPI_C_DOUBLE_COMPLEX, recvbuf, Nxloc*Nyloc*Nzloc, MPI_C_DOUBLE_COMPLEX, & - & MPI_COMM_CART12, ierr) + & MPI_COMM_CART12, ierr) do src_rank = 0, num_procs_y - 1 do l = 1, Nzloc do k = 1, Nyloc do j = 1, Nxloc data_cmplx_y(j, k + src_rank*Nyloc, & - & l) = recvbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + src_rank*Nxloc*Nyloc*Nzloc) + & l) = recvbuf(j + (k - 1)*Nxloc + (l - 1)*Nxloc*Nyloc + src_rank*Nxloc*Nyloc*Nzloc) end do end do end do @@ -820,10 +833,12 @@ contains deallocate (sendbuf) deallocate (recvbuf) #endif + end subroutine s_mpi_transpose_x2y !> @brief Transpose 3-D complex data from y-pencil to z-pencil layout via MPI_Alltoall. subroutine s_mpi_transpose_y2z + complex(c_double_complex), allocatable :: sendbuf(:), recvbuf(:) integer :: dest_rank, src_rank integer :: j, k, l @@ -838,22 +853,22 @@ contains do j = 1, Nxloc do k = 1, Nyloc2 sendbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) + dest_rank*Nyloc2*Nxloc*Nzloc) = data_cmplx_y(j, & - & k + dest_rank*Nyloc2, l) + & k + dest_rank*Nyloc2, l) end do end do end do end do call MPI_Alltoall(sendbuf, Nyloc2*Nxloc*Nzloc, MPI_C_DOUBLE_COMPLEX, recvbuf, Nyloc2*Nxloc*Nzloc, MPI_C_DOUBLE_COMPLEX, & - & MPI_COMM_CART13, ierr) + & MPI_COMM_CART13, ierr) do src_rank = 0, num_procs_z - 1 do l = 1, Nzloc do j = 1, Nxloc do k = 1, Nyloc2 data_cmplx_z(j, k, & - & l + src_rank*Nzloc) = recvbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) & - & + src_rank*Nyloc2*Nxloc*Nzloc) + & l + src_rank*Nzloc) = recvbuf(k + (j - 1)*Nyloc2 + (l - 1)*(Nyloc2*Nxloc) & + & + src_rank*Nyloc2*Nxloc*Nzloc) end do end do end do @@ -862,12 +877,13 @@ contains deallocate (sendbuf) deallocate (recvbuf) #endif + end subroutine s_mpi_transpose_y2z !> @brief Initialize all post-process sub-modules, set up I/O pointers, and prepare FFTW plans and MPI communicators. impure subroutine s_initialize_modules - ! Computation of parameters, allocation procedures, and/or any other tasks - ! needed to properly setup the modules + + ! Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the modules integer :: size_n(1), inembed(1), onembed(1) call s_initialize_global_parameters_module() @@ -923,24 +939,24 @@ contains onembed(1) = Nx fwd_plan_x = fftw_plan_many_dft(1, size_n, Nyloc*Nzloc, data_in, inembed, 1, Nx, data_out, onembed, 1, Nx, & - & FFTW_FORWARD, FFTW_MEASURE) + & FFTW_FORWARD, FFTW_MEASURE) size_n(1) = Ny inembed(1) = Ny onembed(1) = Ny fwd_plan_y = fftw_plan_many_dft(1, size_n, Nxloc*Nzloc, data_out, inembed, 1, Ny, data_in, onembed, 1, Ny, & - & FFTW_FORWARD, FFTW_MEASURE) + & FFTW_FORWARD, FFTW_MEASURE) size_n(1) = Nz inembed(1) = Nz onembed(1) = Nz fwd_plan_z = fftw_plan_many_dft(1, size_n, Nxloc*Nyloc2, data_in, inembed, 1, Nz, data_out, onembed, 1, Nz, & - & FFTW_FORWARD, FFTW_MEASURE) + & FFTW_FORWARD, FFTW_MEASURE) call MPI_CART_CREATE(MPI_COMM_WORLD, 3, (/num_procs_x, num_procs_y, num_procs_z/), (/.true., .true., .true./), & - & .false., MPI_COMM_CART, ierr) + & .false., MPI_COMM_CART, ierr) call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, cart3d_coords, ierr) call MPI_Cart_SUB(MPI_COMM_CART, (/.true., .true., .false./), MPI_COMM_CART12, ierr) @@ -952,10 +968,12 @@ contains call MPI_CART_COORDS(MPI_COMM_CART13, proc_rank13, 2, cart2d13_coords, ierr) end if #endif + end subroutine s_initialize_modules !> @brief Perform a distributed forward 3-D FFT using pencil decomposition with FFTW and MPI transposes. subroutine s_mpi_FFT_fwd + integer :: j, k, l #ifdef MFC_MPI @@ -1018,19 +1036,20 @@ contains end do end do #endif + end subroutine s_mpi_FFT_fwd !> @brief Set up the MPI environment, read and broadcast user inputs, and decompose the computational domain. impure subroutine s_initialize_mpi_domain + num_dims = 1 + min(1, n) + min(1, p) ! Initialization of the MPI environment call s_mpi_initialize() - ! Processor with rank 0 assigns default user input values prior to reading - ! those in from the input file. Next, the user inputs are read in and their - ! consistency is checked. The detection of any inconsistencies automatically - ! leads to the termination of the post-process. + ! Processor with rank 0 assigns default user input values prior to reading those in from the input file. Next, the user + ! inputs are read in and their consistency is checked. The detection of any inconsistencies automatically leads to the + ! termination of the post-process. if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() @@ -1039,24 +1058,22 @@ contains print '(" Post-processing a ", I0, "x", I0, "x", I0, " case on ", I0, " rank(s)")', m, n, p, num_procs end if - ! Broadcasting the user inputs to all of the processors and performing the - ! parallel computational domain decomposition. Neither procedure has to be - ! carried out if the post-process is in fact not truly executed in parallel. + ! Broadcasting the user inputs to all of the processors and performing the parallel computational domain decomposition. + ! Neither procedure has to be carried out if the post-process is in fact not truly executed in parallel. call s_mpi_bcast_user_inputs() call s_initialize_parallel_io() call s_mpi_decompose_computational_domain() call s_check_inputs_fft() + end subroutine s_initialize_mpi_domain !> @brief Destroy FFTW plans, free MPI communicators, and finalize all post-process sub-modules. impure subroutine s_finalize_modules + ! Disassociate pointers for serial and parallel I/O s_read_data_files => null() - ! if (sim_data .and. proc_rank == 0) then - ! call s_close_intf_data_file() - ! call s_close_energy_data_file() - ! end if + ! if (sim_data .and. proc_rank == 0) then call s_close_intf_data_file() call s_close_energy_data_file() end if if (fft_wrt) then if (c_associated(fwd_plan_x)) call fftw_destroy_plan(fwd_plan_x) @@ -1093,5 +1110,7 @@ contains ! Finalizing the MPI environment call s_mpi_finalize() + end subroutine s_finalize_modules + end module m_start_up diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index 01a1c7ed34..1f8450565b 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -7,6 +7,7 @@ !! of the primitive and conservative variables, as well as quantities that can be derived from those such as the unadvected volume !! fraction, specific heat ratio, liquid stiffness, speed of sound, vorticity and the numerical Schlieren function. program p_main + use m_global_parameters !< Global parameters for the code use m_start_up @@ -34,11 +35,9 @@ program p_main ! Time-Marching Loop do - ! If all time-steps are not ready to be post-processed and one rank is - ! faster than another, the slower rank processing the last available - ! step might be killed when the faster rank attempts to process the - ! first missing step, before the slower rank finishes writing the last - ! available step. To avoid this, we force synchronization here. + ! If all time-steps are not ready to be post-processed and one rank is faster than another, the slower rank processing the + ! last available step might be killed when the faster rank attempts to process the first missing step, before the slower + ! rank finishes writing the last available step. To avoid this, we force synchronization here. call s_mpi_barrier() call cpu_time(start) @@ -62,11 +61,9 @@ program p_main exit end if else - ! Modifies the time-step iterator so that it may reach the final time- - ! step to be post-processed, in the case that this one is not originally - ! attainable through constant incrementation from the first time-step. - ! This modification is performed upon reaching the final time-step. In - ! case that it is not needed, the post-processor is done and may exit. + ! Modifies the time-step iterator so that it may reach the final time- step to be post-processed, in the case that this + ! one is not originally attainable through constant incrementation from the first time-step. This modification is + ! performed upon reaching the final time-step. In case that it is not needed, the post-processor is done and may exit. if ((t_step_stop - t_step) < t_step_save .and. t_step_stop /= t_step) then t_step = t_step_stop - t_step_save else if (t_step == t_step_stop) then diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index 60a482b85f..6d29c184db 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -7,6 +7,7 @@ !> @brief Assigns initial primitive variables to computational cells based on patch geometry module m_assign_variables + use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code use m_variables_conversion ! Subroutines to change the state variables from @@ -26,7 +27,7 @@ module m_assign_variables !! the subroutine, to a particular cell in the computational domain abstract interface - !> Skeleton of s_assign_patch_mixture_primitive_variables and s_assign_patch_species_primitive_variables + !> Skeleton of s_assign_patch_mixture_primitive_variables and s_assign_patch_species_primitive_variables !! @param patch_id is the patch identifier !! @param j (x) cell index in which the mixture or species primitive variables from the indicated patch are assigned !! @param k (y,th) cell index in which the mixture or species primitive variables from the indicated patch are assigned @@ -35,6 +36,7 @@ module m_assign_variables !! @param q_prim_vf Primitive variables !! @param patch_id_fp Array to track patch ids subroutine s_assign_patch_xxxxx_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) + import :: scalar_field, sys_size, n, m, p, wp integer, intent(in) :: patch_id @@ -46,29 +48,32 @@ module m_assign_variables #else integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif + end subroutine s_assign_patch_xxxxx_primitive_variables end interface private; public :: s_initialize_assign_variables_module, s_assign_patch_primitive_variables, & & s_assign_patch_mixture_primitive_variables, s_assign_patch_species_primitive_variables, s_finalize_assign_variables_module + contains !> @brief Allocates volume fraction sum and sets the patch primitive variable assignment procedure pointer. impure subroutine s_initialize_assign_variables_module + if (.not. igr) then allocate (alf_sum%sf(0:m, 0:n, 0:p)) end if - ! Depending on multicomponent flow model, the appropriate procedure - ! for assignment of the patch mixture or species primitive variables - ! to a cell in the domain is targeted by the procedure pointer + ! Depending on multicomponent flow model, the appropriate procedure for assignment of the patch mixture or species primitive + ! variables to a cell in the domain is targeted by the procedure pointer if (model_eqns == 1) then ! Gamma/pi_inf model s_assign_patch_primitive_variables => s_assign_patch_mixture_primitive_variables else ! Volume fraction model s_assign_patch_primitive_variables => s_assign_patch_species_primitive_variables end if + end subroutine s_initialize_assign_variables_module !> This subroutine assigns the mixture primitive variables of the patch designated by the patch_id, to the cell that is @@ -76,14 +81,15 @@ contains !! with the new assignment. Note that if the smoothing of the patch's boundaries is employed, the ensuing primitive variables in !! the cell will be a type of combination of the current patch's primitive variables with those of the smoothing patch. The !! specific details of the combination may be found in Shyue's work (1998). - !! @param patch_id the patch identifier - !! @param j the x-dir node index - !! @param k the y-dir node index - !! @param l the z-dir node index - !! @param eta pseudo volume fraction - !! @param q_prim_vf Primitive variables - !! @param patch_id_fp Array to track patch ids + !! @param patch_id the patch identifier + !! @param j the x-dir node index + !! @param k the y-dir node index + !! @param l the z-dir node index + !! @param eta pseudo volume fraction + !! @param q_prim_vf Primitive variables + !! @param patch_id_fp Array to track patch ids subroutine s_assign_patch_mixture_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) + $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: patch_id @@ -110,8 +116,8 @@ contains ! Velocity do i = 1, E_idx - mom_idx%beg q_prim_vf(i + 1)%sf(j, k, l) = 1._wp/q_prim_vf(1)%sf(j, k, & - & l)*(eta*patch_icpp(patch_id)%rho*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*patch_icpp(smooth_patch_id) & - & %rho*patch_icpp(smooth_patch_id)%vel(i)) + & l)*(eta*patch_icpp(patch_id)%rho*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*patch_icpp(smooth_patch_id) & + & %rho*patch_icpp(smooth_patch_id)%vel(i)) end do ! Specific heat ratio function @@ -119,8 +125,8 @@ contains ! Pressure q_prim_vf(E_idx)%sf(j, k, l) = 1._wp/q_prim_vf(gamma_idx)%sf(j, k, & - & l)*(eta*patch_icpp(patch_id)%gamma*patch_icpp(patch_id)%pres + (1._wp - eta)*patch_icpp(smooth_patch_id) & - & %gamma*patch_icpp(smooth_patch_id)%pres) + & l)*(eta*patch_icpp(patch_id)%gamma*patch_icpp(patch_id)%pres + (1._wp - eta)*patch_icpp(smooth_patch_id) & + & %gamma*patch_icpp(smooth_patch_id)%pres) ! Liquid stiffness function q_prim_vf(pi_inf_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%pi_inf + (1._wp - eta)*patch_icpp(smooth_patch_id)%pi_inf @@ -150,6 +156,7 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < 1.e-16_wp) patch_id_fp(j, k, l) = patch_id + end subroutine s_assign_patch_mixture_primitive_variables !> @brief Applies a stable pressure perturbation following Ando's method for bubble-laden flows. @@ -158,6 +165,7 @@ contains !! @param l the z-dir node index !! @param q_prim_vf Primitive variables subroutine s_perturb_primitive(j, k, l, q_prim_vf) + integer, intent(in) :: j, k, l type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i @@ -177,7 +185,7 @@ contains if (qbmm) then do i = 1, nb q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) = q_prim_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, & - & l)*((p0 - bub_pp%pv)/(q_prim_vf(E_idx)%sf(j, k, l)*p0 - bub_pp%pv))**(1._wp/3._wp) + & l)*((p0 - bub_pp%pv)/(q_prim_vf(E_idx)%sf(j, k, l)*p0 - bub_pp%pv))**(1._wp/3._wp) end do end if @@ -223,18 +231,20 @@ contains end do q_prim_vf(alf_idx)%sf(j, k, l) = vfH + end subroutine s_perturb_primitive !> This subroutine assigns the species primitive variables. This follows s_assign_patch_species_primitive_variables with !! adaptation for ensemble-averaged bubble modeling - !! @param patch_id the patch identifier - !! @param j the x-dir node index - !! @param k the y-dir node index - !! @param l the z-dir node index - !! @param eta pseudo volume fraction - !! @param q_prim_vf Primitive variables - !! @param patch_id_fp Array to track patch ids + !! @param patch_id the patch identifier + !! @param j the x-dir node index + !! @param k the y-dir node index + !! @param l the z-dir node index + !! @param eta pseudo volume fraction + !! @param q_prim_vf Primitive variables + !! @param patch_id_fp Array to track patch ids impure subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) + $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: patch_id @@ -247,9 +257,8 @@ contains #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - ! Density, the specific heat ratio function and the liquid stiffness - ! function, respectively, obtained from the combination of primitive - ! variables of the current and smoothing patches + ! Density, the specific heat ratio function and the liquid stiffness function, respectively, obtained from the combination + ! of primitive variables of the current and smoothing patches real(wp) :: rho !< density real(wp) :: gamma real(wp) :: lit_gamma !< specific heat ratio @@ -288,8 +297,7 @@ contains end do end if - ! Computing Mixture Variables from Original Primitive Variables - ! call s_convert_species_to_mixture_variables( & + ! Computing Mixture Variables from Original Primitive Variables call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, orig_rho, orig_gamma, orig_pi_inf, orig_qv) ! Computing Mixture Variables of Current Patch @@ -320,10 +328,9 @@ contains end do end if - ! Density and the specific heat ratio and liquid stiffness functions - ! call s_convert_species_to_mixture_variables( & + ! Density and the specific heat ratio and liquid stiffness functions call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, patch_icpp(patch_id)%rho, patch_icpp(patch_id)%gamma, & - & patch_icpp(patch_id)%pi_inf, patch_icpp(patch_id)%qv) + & patch_icpp(patch_id)%pi_inf, patch_icpp(patch_id)%qv) ! Computing Mixture Variables of Smoothing Patch @@ -395,10 +402,10 @@ contains end if end if - ! Density and the specific heat ratio and liquid stiffness functions - ! call s_convert_species_to_mixture_variables( & + ! Density and the specific heat ratio and liquid stiffness functions call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, patch_icpp(smooth_patch_id)%rho, & - & patch_icpp(smooth_patch_id)%gamma, patch_icpp(smooth_patch_id)%pi_inf, patch_icpp(smooth_patch_id)%qv) + & patch_icpp(smooth_patch_id)%gamma, patch_icpp(smooth_patch_id)%pi_inf, & + & patch_icpp(smooth_patch_id)%qv) ! Pressure q_prim_vf(E_idx)%sf(j, k, l) = (eta*patch_icpp(patch_id)%pres + (1._wp - eta)*orig_prim_vf(E_idx)) @@ -425,7 +432,7 @@ contains if (elasticity) then do i = 1, (stress_idx%end - stress_idx%beg) + 1 q_prim_vf(i + stress_idx%beg - 1)%sf(j, k, & - & l) = (eta*patch_icpp(patch_id)%tau_e(i) + (1._wp - eta)*orig_prim_vf(i + stress_idx%beg - 1)) + & l) = (eta*patch_icpp(patch_id)%tau_e(i) + (1._wp - eta)*orig_prim_vf(i + stress_idx%beg - 1)) end do end if @@ -478,17 +485,17 @@ contains ! \rho = (( p_l + pi_inf)/( p_ref + pi_inf))**(1/little_gam) * rhoref(1-alf) q_prim_vf(1)%sf(j, k, l) = (((q_prim_vf(E_idx)%sf(j, k, & - & l) + pi_inf)/(pref + pi_inf))**(1/lit_gamma))*rhoref*(1 - q_prim_vf(alf_idx)%sf(j, k, l)) + & l) + pi_inf)/(pref + pi_inf))**(1/lit_gamma))*rhoref*(1 - q_prim_vf(alf_idx)%sf(j, k, l)) end if - ! Density and the specific heat ratio and liquid stiffness functions - ! call s_convert_species_to_mixture_variables(q_prim_vf, j, k, l, & + ! Density and the specific heat ratio and liquid stiffness functions call s_convert_species_to_mixture_variables(q_prim_vf, + ! j, k, l, & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, rho, gamma, pi_inf, qv) ! Velocity do i = 1, E_idx - mom_idx%beg q_prim_vf(i + cont_idx%end)%sf(j, k, & - & l) = (eta*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*orig_prim_vf(i + cont_idx%end)) + & l) = (eta*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*orig_prim_vf(i + cont_idx%end)) end do ! Species Concentrations @@ -519,8 +526,8 @@ contains ! Set streamwise velocity to hyperbolic tangent function of y if (mixlayer_vel_profile) then q_prim_vf(1 + cont_idx%end)%sf(j, k, & - & l) = (eta*patch_icpp(patch_id)%vel(1)*tanh(y_cc(k)*mixlayer_vel_coef) + (1._wp - eta)*orig_prim_vf(1 & - & + cont_idx%end)) + & l) = (eta*patch_icpp(patch_id)%vel(1)*tanh(y_cc(k)*mixlayer_vel_coef) + (1._wp - eta)*orig_prim_vf(1 & + & + cont_idx%end)) end if ! Set partial pressures to mixture pressure for the 6-eqn model @@ -604,21 +611,19 @@ contains ! Updating the patch identities bookkeeping variable if (1._wp - eta < 1.e-16_wp) patch_id_fp(j, k, l) = patch_id - ! if (j == 1) then - ! print *, (q_prim_vf(bub_idx%rs(i))%sf(j, k, l), i = 1, nb) - ! print *, (q_prim_vf(bub_idx%fullmom(i, 1, 0))%sf(j, k, l), i = 1, nb) - ! print *, (R0(i), i = 1, nb) - ! print *, patch_icpp(patch_id)%r0 - ! print *, (bub_idx%rs(i), i = 1, nb) - ! print *, (bub_idx%fullmom(i, 1, 0), i = 1, nb) - ! end if + ! if (j == 1) then print *, (q_prim_vf(bub_idx%rs(i))%sf(j, k, l), i = 1, nb) print *, (q_prim_vf(bub_idx%fullmom(i, 1, + ! 0))%sf(j, k, l), i = 1, nb) print *, (R0(i), i = 1, nb) print *, patch_icpp(patch_id)%r0 print *, (bub_idx%rs(i), i = 1, + ! nb) print *, (bub_idx%fullmom(i, 1, 0), i = 1, nb) end if + end subroutine s_assign_patch_species_primitive_variables !> @brief Nullifies the patch primitive variable assignment procedure pointer. impure subroutine s_finalize_assign_variables_module - ! Nullifying procedure pointer to the subroutine assigning either - ! the patch mixture or species primitive variables to a cell in the - ! computational domain + + ! Nullifying procedure pointer to the subroutine assigning either the patch mixture or species primitive variables to a cell + ! in the computational domain s_assign_patch_primitive_variables => null() + end subroutine s_finalize_assign_variables_module + end module m_assign_variables diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index d3c169aa91..051dd7d18d 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -4,6 +4,7 @@ !> @brief Applies spatially varying boundary condition patches along domain edges and faces module m_boundary_conditions + use m_derived_types use m_global_parameters #ifdef MFC_MPI @@ -20,14 +21,17 @@ module m_boundary_conditions real(wp) :: radius type(bounds_info) :: x_boundary, y_boundary, z_boundary private; public :: s_apply_boundary_patches + contains !> @brief Applies a line-segment boundary condition patch along a domain edge in 2D. impure subroutine s_line_segment_bc(patch_id, bc_type) + type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type integer, intent(in) :: patch_id integer :: j ! Patch is a vertical line at x_beg or x_end + if (patch_bc(patch_id)%dir == 1) then y_centroid = patch_bc(patch_id)%centroid(2) length_y = patch_bc(patch_id)%length(2) @@ -66,13 +70,16 @@ contains end if #:endfor end if + end subroutine s_line_segment_bc !> @brief Applies a circular boundary condition patch on a domain face in 3D. impure subroutine s_circle_bc(patch_id, bc_type) + type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type integer, intent(in) :: patch_id integer :: j, k + if (patch_bc(patch_id)%dir == 1) then y_centroid = patch_bc(patch_id)%centroid(2) z_centroid = patch_bc(patch_id)%centroid(3) @@ -123,13 +130,16 @@ contains end if #:endfor end if + end subroutine s_circle_bc !> @brief Applies a rectangular boundary condition patch on a domain face in 3D. impure subroutine s_rectangle_bc(patch_id, bc_type) + type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type integer, intent(in) :: patch_id integer :: j, k + if (patch_bc(patch_id)%dir == 1) then y_centroid = patch_bc(patch_id)%centroid(2) z_centroid = patch_bc(patch_id)%centroid(3) @@ -204,15 +214,18 @@ contains end if #:endfor end if + end subroutine s_rectangle_bc !> @brief Iterates over all boundary condition patches and dispatches them by geometry type. impure subroutine s_apply_boundary_patches(q_prim_vf, bc_type) + type(scalar_field), dimension(sys_size) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2) :: bc_type integer :: i - !< Apply 2D patches to 3D domain + !> Apply 2D patches to 3D domain + if (p > 0) then do i = 1, num_bc_patches if (proc_rank == 0) then @@ -225,7 +238,7 @@ contains call s_rectangle_bc(i, bc_type) end if end do - !< Apply 1D patches to 2D domain + !> Apply 1D patches to 2D domain else if (n > 0) then do i = 1, num_bc_patches if (proc_rank == 0) then @@ -237,5 +250,7 @@ contains end if end do end if + end subroutine s_apply_boundary_patches + end module m_boundary_conditions diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index 2c1ba59b05..b8090ab1c7 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -7,10 +7,11 @@ #:include 'macros.fpp' module m_check_ib_patches - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Procedures to write the grid data and the conservative variables to files + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_data_output !< Procedures to write the grid data and the conservative variables to files #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -25,10 +26,12 @@ module m_check_ib_patches public :: s_check_ib_patches character(len=10) :: iStr + contains !> @brief Validates the geometry parameters of all active and inactive immersed boundary patches. impure subroutine s_check_ib_patches + integer :: i do i = 1, num_patches_max @@ -58,126 +61,144 @@ contains call s_check_ellipse_ib_patch_geometry(i) else call s_prohibit_abort("Invalid IB patch", & - & "patch_ib(" // trim(iStr) // ")%geometry must be " // "2-4, 8-10, 11 or 12.") + & "patch_ib(" // trim(iStr) // ")%geometry must be " // "2-4, 8-10, 11 or 12.") end if else @:PROHIBIT(patch_ib(i)%geometry /= dflt_int, & - & "Inactive IB patch defined. " // "patch_ib(" // trim(iStr) & - & // ")%geometry must not be set for inactive patches.") + & "Inactive IB patch defined. " // "patch_ib(" // trim(iStr) & + & // ")%geometry must not be set for inactive patches.") call s_check_inactive_ib_patch_geometry(i) end if end do + end subroutine s_check_ib_patches !> This subroutine verifies that the geometric parameters of the circle patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_circle_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%radius <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) & - & .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in circle IB patch ' // trim(iStr)) + & .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in circle IB patch ' // trim(iStr)) + end subroutine s_check_circle_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the ellipse patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_ellipse_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id) & - & %length_y <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & - & %y_centroid), 'in ellipse IB patch ' // trim(iStr)) + & %length_y <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & + & %y_centroid), 'in ellipse IB patch ' // trim(iStr)) + end subroutine s_check_ellipse_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the airfoil patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_airfoil_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p > 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id)%p <= 0._wp .or. patch_ib(patch_id) & - & %t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) & - & .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in airfoil IB patch ' // trim(iStr)) + & %t <= 0._wp .or. patch_ib(patch_id)%m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) & + & .or. f_is_default(patch_ib(patch_id)%y_centroid), 'in airfoil IB patch ' // trim(iStr)) + end subroutine s_check_airfoil_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the 3d airfoil patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_3d_airfoil_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p == 0 .or. patch_ib(patch_id)%c <= 0._wp .or. patch_ib(patch_id) & - & %p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id) & - & %m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) & - & .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. f_is_default(patch_ib(patch_id)%length_z), & - & 'in 3d airfoil IB patch ' // trim(iStr)) + & %p <= 0._wp .or. patch_ib(patch_id)%t <= 0._wp .or. patch_ib(patch_id) & + & %m <= 0._wp .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) & + & .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. f_is_default(patch_ib(patch_id)%length_z), & + & 'in 3d airfoil IB patch ' // trim(iStr)) + end subroutine s_check_3d_airfoil_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the rectangle patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_rectangle_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p > 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & - & %y_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp, & - & 'in rectangle IB patch ' // trim(iStr)) + & %y_centroid) .or. patch_ib(patch_id)%length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp, & + & 'in rectangle IB patch ' // trim(iStr)) + end subroutine s_check_rectangle_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the sphere patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_sphere_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & - & %y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%radius <= 0._wp, & - & 'in sphere IB patch ' // trim(iStr)) + & %y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id)%radius <= 0._wp, & + & 'in sphere IB patch ' // trim(iStr)) + end subroutine s_check_sphere_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the cuboid patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_cuboid_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0 .or. p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id) & - & %y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id) & - & %length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. patch_ib(patch_id)%length_z <= 0._wp, & - & 'in cuboid IB patch ' // trim(iStr)) + & %y_centroid) .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. patch_ib(patch_id) & + & %length_x <= 0._wp .or. patch_ib(patch_id)%length_y <= 0._wp .or. patch_ib(patch_id)%length_z <= 0._wp, & + & 'in cuboid IB patch ' // trim(iStr)) + end subroutine s_check_cuboid_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the cylinder patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_cylinder_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0 .or. f_is_default(patch_ib(patch_id)%x_centroid) .or. f_is_default(patch_ib(patch_id)%y_centroid) & - & .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. (patch_ib(patch_id) & - & %length_x <= 0._wp .and. patch_ib(patch_id)%length_y <= 0._wp .and. patch_ib(patch_id)%length_z <= 0._wp) & - & .or. patch_ib(patch_id)%radius <= 0._wp, 'in cylinder IB patch ' // trim(iStr)) + & .or. f_is_default(patch_ib(patch_id)%z_centroid) .or. (patch_ib(patch_id) & + & %length_x <= 0._wp .and. patch_ib(patch_id)%length_y <= 0._wp .and. patch_ib(patch_id)%length_z <= 0._wp) & + & .or. patch_ib(patch_id)%radius <= 0._wp, 'in cylinder IB patch ' // trim(iStr)) @:PROHIBIT((patch_ib(patch_id)%length_x > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_y)) & - & .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id) & - & %length_y > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) & - & .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id) & - & %length_z > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) & - & .or. (.not. f_is_default(patch_ib(patch_id)%length_y)))), 'in cylinder IB patch ' // trim(iStr)) + & .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id) & + & %length_y > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%length_z)))) .or. (patch_ib(patch_id) & + & %length_z > 0._wp .and. ((.not. f_is_default(patch_ib(patch_id)%length_x)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%length_y)))), 'in cylinder IB patch ' // trim(iStr)) + end subroutine s_check_cylinder_ib_patch_geometry !> This subroutine verifies that the geometric parameters of the model patch have consistently been inputted by the user. !! @param patch_id Patch identifier impure subroutine s_check_model_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -185,20 +206,24 @@ contains @:PROHIBIT(patch_ib(patch_id)%model_filepath == dflt_char, 'Empty model file path for patch '//trim(iStr)) @:PROHIBIT(patch_ib(patch_id)%model_scale(1) <= 0._wp .or. patch_ib(patch_id)%model_scale(2) & - & <= 0._wp .or. patch_ib(patch_id)%model_scale(3) <= 0._wp, 'Negative scale in model IB patch ' // trim(iStr)) + & <= 0._wp .or. patch_ib(patch_id)%model_scale(3) <= 0._wp, 'Negative scale in model IB patch ' // trim(iStr)) + end subroutine s_check_model_ib_patch_geometry !!> This subroutine verifies that the geometric parameters of - !! the inactive patch remain unaltered by the user inputs. - !! @param patch_id Patch identifier + !! the inactive patch remain unaltered by the user inputs. @param patch_id Patch identifier impure subroutine s_check_inactive_ib_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT((.not. f_is_default(patch_ib(patch_id)%x_centroid)) .or. (.not. f_is_default(patch_ib(patch_id)%y_centroid)) & - & .or. (.not. f_is_default(patch_ib(patch_id)%z_centroid)) .or. (.not. f_is_default(patch_ib(patch_id) %length_x)) & - & .or. (.not. f_is_default(patch_ib(patch_id)%length_y)) .or. (.not. f_is_default(patch_ib(patch_id)%length_z)) & - & .or. (.not. f_is_default(patch_ib(patch_id)%radius)), 'in inactive IB patch ' // trim(iStr)) + & .or. (.not. f_is_default(patch_ib(patch_id)%z_centroid)) .or. (.not. f_is_default(patch_ib(patch_id) & + & %length_x)) .or. (.not. f_is_default(patch_ib(patch_id)%length_y)) & + & .or. (.not. f_is_default(patch_ib(patch_id)%length_z)) .or. (.not. f_is_default(patch_ib(patch_id)%radius)), & + & 'in inactive IB patch ' // trim(iStr)) + end subroutine s_check_inactive_ib_patch_geometry + end module m_check_ib_patches diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 44a5170fa7..69c917616e 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -9,11 +9,12 @@ #:include 'macros.fpp' module m_check_patches + ! Dependencies - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Procedures to write the grid data and the conservative variables to files + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_data_output !< Procedures to write the grid data and the conservative variables to files #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -27,10 +28,12 @@ module m_check_patches private; public :: s_check_patches character(len=10) :: iStr + contains !> @brief Validates the geometry parameters of all active and inactive initial condition patches. impure subroutine s_check_patches + integer :: i character(len=10) :: num_patches_str @@ -41,13 +44,13 @@ contains ! call s_check_patch_geometry(i) call s_int_to_str(i, iStr) @:PROHIBIT(patch_icpp(i)%geometry == 6, & - & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") + & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") @:PROHIBIT(patch_icpp(i)%geometry == 7, & - & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") + & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") @:PROHIBIT(patch_icpp(i)%geometry == 15, & - & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") + & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") @:PROHIBIT(patch_icpp(i)%geometry == dflt_int, & - & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry must be set.") + & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry must be set.") ! Constraints on the geometric initial condition patch parameters if (patch_icpp(i)%geometry == 1) then @@ -80,12 +83,13 @@ contains call s_check_model_geometry(i) else call s_prohibit_abort("Invalid patch geometry number", & - & "patch_icpp(" // trim(iStr) // ")%geometry " // "must be between 1 and 21") + & "patch_icpp(" // trim(iStr) // ")%geometry " // "must be between 1 and 21") end if else @:PROHIBIT(patch_icpp(i)%geometry /= dflt_int, & - & "Inactive patch defined. " // "patch_icpp(" // trim(iStr) // ")%geometry not be set for inactive patches. " & - & // "Patch " // trim(iStr) // " is inactive as the number of patches is " // trim(num_patches_str)) + & "Inactive patch defined. " // "patch_icpp(" // trim(iStr) & + & // ")%geometry not be set for inactive patches. " // "Patch " // trim(iStr) & + & // " is inactive as the number of patches is " // trim(num_patches_str)) call s_check_inactive_patch_geometry(i) end if end do @@ -119,25 +123,31 @@ contains call s_check_inactive_patch_primitive_variables(i) end if end do + end subroutine s_check_patches !> This subroutine checks the line segment patch input !! @param patch_id Patch identifier impure subroutine s_check_line_segment_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n > 0, "Line segment patch "//trim(iStr)//": n must be zero") @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, & - & "Line segment patch " // trim(iStr) // ": length_x must be greater than zero") + & "Line segment patch " // trim(iStr) // ": length_x must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Line segment patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(cyl_coord, "Line segment patch "//trim(iStr)//": cyl_coord is not supported") + end subroutine s_check_line_segment_patch_geometry !> This subroutine checks the circle patch input !! @param patch_id Patch identifier impure subroutine s_check_circle_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0, "Circle patch "//trim(iStr)//": n must be zero") @@ -145,12 +155,15 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "Circle patch "//trim(iStr)//": radius must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Circle patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Circle patch "//trim(iStr)//": y_centroid must be set") + end subroutine s_check_circle_patch_geometry !> This subroutine checks the rectangle patch input !! @param patch_id Patch identifier impure subroutine s_check_rectangle_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0, "Rectangle patch "//trim(iStr)//": n must be greater than zero") @@ -159,12 +172,15 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Rectangle patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Rectangle patch "//trim(iStr)//": length_x must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Rectangle patch "//trim(iStr)//": length_y must be greater than zero") + end subroutine s_check_rectangle_patch_geometry !> This subroutine checks the line sweep patch input !! @param patch_id Patch identifier impure subroutine s_check_line_sweep_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0, "Line sweep patch "//trim(iStr)//": n must be greater than zero") @@ -174,13 +190,16 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(1)), "Line sweep patch "//trim(iStr)//": normal(1) must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(2)), "Line sweep patch "//trim(iStr)//": normal(2) must be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%normal(3)), & - & "Line sweep patch " // trim(iStr) // ": normal(3) must not be set") + & "Line sweep patch " // trim(iStr) // ": normal(3) must not be set") + end subroutine s_check_line_sweep_patch_geometry !> This subroutine checks the ellipse patch input !! @param patch_id Patch identifier impure subroutine s_check_ellipse_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0, "Ellipse patch "//trim(iStr)//": n must be greater than zero") @@ -190,32 +209,38 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radii(1) <= 0._wp, "Ellipse patch "//trim(iStr)//": radii(1) must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0._wp, "Ellipse patch "//trim(iStr)//": radii(2) must be greater than zero") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(3)), "Ellipse patch "//trim(iStr)//": radii(3) must not be set") + end subroutine s_check_ellipse_patch_geometry !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_2D_TaylorGreen_vortex_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(n == 0, "Taylor Green vortex patch "//trim(iStr)//": n must be greater than zero") @:PROHIBIT(p > 0, "Taylor Green vortex patch "//trim(iStr)//": p must be zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), & - & "Taylor Green vortex patch " // trim(iStr) // ": x_centroid must be set") + & "Taylor Green vortex patch " // trim(iStr) // ": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), & - & "Taylor Green vortex patch " // trim(iStr) // ": y_centroid must be set") + & "Taylor Green vortex patch " // trim(iStr) // ": y_centroid must be set") @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, & - & "Taylor Green vortex patch " // trim(iStr) // ": length_x must be greater than zero") + & "Taylor Green vortex patch " // trim(iStr) // ": length_x must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, & - & "Taylor Green vortex patch " // trim(iStr) // ": length_y must be greater than zero") + & "Taylor Green vortex patch " // trim(iStr) // ": length_y must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%vel(2) <= 0._wp, & - & "Taylor Green vortex patch " // trim(iStr) // ": vel(2) must be greater than zero") + & "Taylor Green vortex patch " // trim(iStr) // ": vel(2) must be greater than zero") + end subroutine s_check_2D_TaylorGreen_vortex_patch_geometry !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_sphere_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Sphere patch "//trim(iStr)//": p must be greater than zero") @@ -223,9 +248,11 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "Sphere patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "Sphere patch "//trim(iStr)//": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), "Sphere patch "//trim(iStr)//": z_centroid must be set") + end subroutine s_check_sphere_patch_geometry impure subroutine s_check_2d_modal_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @@ -235,29 +262,34 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, "2D modal patch "//trim(iStr)//": radius must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), "2D modal patch "//trim(iStr)//": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), "2D modal patch "//trim(iStr)//": y_centroid must be set") + end subroutine s_check_2d_modal_patch_geometry impure subroutine s_check_3d_spherical_harmonic_patch_geometry(patch_id) + integer, intent(in) :: patch_id call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Spherical harmonic patch "//trim(iStr)//": p must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%radius <= 0._wp, & - & "Spherical harmonic patch " // trim(iStr) // ": radius must be greater than zero") + & "Spherical harmonic patch " // trim(iStr) // ": radius must be greater than zero") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%x_centroid), & - & "Spherical harmonic patch " // trim(iStr) // ": x_centroid must be set") + & "Spherical harmonic patch " // trim(iStr) // ": x_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%y_centroid), & - & "Spherical harmonic patch " // trim(iStr) // ": y_centroid must be set") + & "Spherical harmonic patch " // trim(iStr) // ": y_centroid must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%z_centroid), & - & "Spherical harmonic patch " // trim(iStr) // ": z_centroid must be set") + & "Spherical harmonic patch " // trim(iStr) // ": z_centroid must be set") + end subroutine s_check_3d_spherical_harmonic_patch_geometry !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_cuboid_patch_geometry(patch_id) + ! Patch identifier integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Cuboid patch "//trim(iStr)//": p must be greater than zero") @@ -267,13 +299,16 @@ contains @:PROHIBIT(patch_icpp(patch_id)%length_x <= 0._wp, "Cuboid patch "//trim(iStr)//": length_x must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_y <= 0._wp, "Cuboid patch "//trim(iStr)//": length_y must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%length_z <= 0._wp, "Cuboid patch "//trim(iStr)//": length_z must be greater than zero") + end subroutine s_check_cuboid_patch_geometry !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_cylinder_patch_geometry(patch_id) + ! Patch identifier integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Cylinder patch "//trim(iStr)//": p must be greater than zero") @@ -284,21 +319,25 @@ contains ! Check if exactly one length is defined @:PROHIBIT(count([patch_icpp(patch_id)%length_x > 0._wp, patch_icpp(patch_id)%length_y > 0._wp, & - & patch_icpp(patch_id)%length_z > 0._wp]) /= 1, & - & "Cylinder patch " // trim(iStr) // ": Exactly one of length_x, length_y, or length_z must be defined and positive") + & patch_icpp(patch_id)%length_z > 0._wp]) /= 1, & + & "Cylinder patch " // trim(iStr) & + & // ": Exactly one of length_x, length_y, or length_z must be defined and positive") ! Ensure the defined length is positive @:PROHIBIT((.not. f_is_default(patch_icpp(patch_id)%length_x) .and. patch_icpp(patch_id)%length_x <= 0._wp) & - & .or. (.not. f_is_default(patch_icpp(patch_id)%length_y) .and. patch_icpp(patch_id)%length_y <= 0._wp) & - & .or. (.not. f_is_default(patch_icpp(patch_id)%length_z) .and. patch_icpp(patch_id)%length_z <= 0._wp), & - & "Cylinder patch " // trim(iStr) // ": The defined length_{} must be greater than zero") + & .or. (.not. f_is_default(patch_icpp(patch_id)%length_y) .and. patch_icpp(patch_id)%length_y <= 0._wp) & + & .or. (.not. f_is_default(patch_icpp(patch_id)%length_z) .and. patch_icpp(patch_id)%length_z <= 0._wp), & + & "Cylinder patch " // trim(iStr) // ": The defined length_{} must be greater than zero") + end subroutine s_check_cylinder_patch_geometry !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_plane_sweep_patch_geometry(patch_id) + ! Patch identifier integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Plane sweep patch "//trim(iStr)//": p must be greater than zero") @@ -308,12 +347,15 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(1)), "Plane sweep patch "//trim(iStr)//": normal(1) must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(2)), "Plane sweep patch "//trim(iStr)//": normal(2) must be set") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%normal(3)), "Plane sweep patch "//trim(iStr)//": normal(3) must be set") + end subroutine s_check_plane_sweep_patch_geometry !> This subroutine checks the model patch input !! @param patch_id Patch identifier impure subroutine s_check_ellipsoid_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(p == 0, "Ellipsoid patch "//trim(iStr)//": p must be greater than zero") @@ -323,21 +365,23 @@ contains @:PROHIBIT(patch_icpp(patch_id)%radii(1) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(1) must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%radii(2) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(2) must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%radii(3) <= 0._wp, "Ellipsoid patch "//trim(iStr)//": radii(3) must be greater than zero") + end subroutine s_check_ellipsoid_patch_geometry !!> This subroutine verifies that the geometric parameters of - !! the inactive patch remain unaltered by the user inputs. - !! @param patch_id Patch identifier + !! the inactive patch remain unaltered by the user inputs. @param patch_id Patch identifier impure subroutine s_check_inactive_patch_geometry(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%x_centroid), & - & "Inactive patch " // trim(iStr) // ": x_centroid must not be set") + & "Inactive patch " // trim(iStr) // ": x_centroid must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%y_centroid), & - & "Inactive patch " // trim(iStr) // ": y_centroid must not be set") + & "Inactive patch " // trim(iStr) // ": y_centroid must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%z_centroid), & - & "Inactive patch " // trim(iStr) // ": z_centroid must not be set") + & "Inactive patch " // trim(iStr) // ": z_centroid must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%length_x), "Inactive patch "//trim(iStr)//": length_x must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%length_y), "Inactive patch "//trim(iStr)//": length_y must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%length_z), "Inactive patch "//trim(iStr)//": length_z must not be set") @@ -350,70 +394,84 @@ contains @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(1)), "Inactive patch "//trim(iStr)//": radii(1) must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(2)), "Inactive patch "//trim(iStr)//": radii(2) must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%radii(3)), "Inactive patch "//trim(iStr)//": radii(3) must not be set") + end subroutine s_check_inactive_patch_geometry !> This subroutine verifies the active patch's right to overwrite the preceding patches !! @param patch_id Patch identifier impure subroutine s_check_active_patch_alteration_rights(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(.not. patch_icpp(patch_id)%alter_patch(0), "Patch "//trim(iStr)//": alter_patch(0) must be true") @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(patch_id:)), & - & "Patch " // trim(iStr) // ":alter_patch(i) must be false for i >= " // trim(iStr) & - & // ". Only preceding patches can be altered") + & "Patch " // trim(iStr) // ":alter_patch(i) must be false for i >= " // trim(iStr) & + & // ". Only preceding patches can be altered") + end subroutine s_check_active_patch_alteration_rights !> This subroutine verifies that inactive patches cannot overwrite other patches !! @param patch_id Patch identifier impure subroutine s_check_inactive_patch_alteration_rights(patch_id) + ! Patch identifier integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(.not. patch_icpp(patch_id)%alter_patch(0), "Inactive patch "//trim(iStr)//": cannot have alter_patch(0) altered") @:PROHIBIT(any(patch_icpp(patch_id)%alter_patch(1:)), & - & "Inactive patch " // trim(iStr) // ": cannot have any alter_patch(i) enabled") + & "Inactive patch " // trim(iStr) // ": cannot have any alter_patch(i) enabled") + end subroutine s_check_inactive_patch_alteration_rights !> This subroutine checks the smoothing parameters !! @param patch_id Patch identifier impure subroutine s_check_supported_patch_smoothing(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) if (patch_icpp(patch_id)%smoothen) then @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id >= patch_id, & - & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_patch_id must be less than patch_id") + & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_patch_id must be less than patch_id") @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id == 0, & - & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_patch_id must be greater than zero") + & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_patch_id must be greater than zero") @:PROHIBIT(patch_icpp(patch_id)%smooth_coeff <= 0._wp, & - & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_coeff must be greater than zero") + & "Smoothen enabled. Patch " // trim(iStr) // ": smooth_coeff must be greater than zero") else @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, & - & "Smoothen disabled. Patch " // trim(iStr) // ": smooth_patch_id must be equal to patch_id") + & "Smoothen disabled. Patch " // trim(iStr) // ": smooth_patch_id must be equal to patch_id") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), & - & "Smoothen disabled. Patch " // trim(iStr) // ": smooth_coeff must not be set") + & "Smoothen disabled. Patch " // trim(iStr) // ": smooth_coeff must not be set") end if + end subroutine s_check_supported_patch_smoothing !> This subroutine verifies that inactive patches cannot be smoothed !! @param patch_id Patch identifier impure subroutine s_check_unsupported_patch_smoothing(patch_id) + ! Patch identifier integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(patch_icpp(patch_id)%smoothen, "Inactive patch "//trim(iStr)//": cannot have smoothen enabled") @:PROHIBIT(patch_icpp(patch_id)%smooth_patch_id /= patch_id, & - & "Inactive patch " // trim(iStr) // ": smooth_patch_id must be equal to patch_id") + & "Inactive patch " // trim(iStr) // ": smooth_patch_id must be equal to patch_id") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%smooth_coeff), & - & "Inactive patch " // trim(iStr) // ": smooth_coeff must not be set") + & "Inactive patch " // trim(iStr) // ": smooth_coeff must not be set") + end subroutine s_check_unsupported_patch_smoothing !> This subroutine checks the primitive variables !! @param patch_id Patch identifier impure subroutine s_check_active_patch_primitive_variables(patch_id) + integer, intent(in) :: patch_id logical, dimension(3) :: is_set_B @@ -421,23 +479,24 @@ contains @:PROHIBIT(f_is_default(patch_icpp(patch_id)%vel(1)), "Patch "//trim(iStr)//": vel(1) must be set") @:PROHIBIT(n == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(2))) .and. (.not. f_approx_equal(patch_icpp(patch_id) & - & %vel(2), 0._wp)) .and. (.not. mhd), "Patch " // trim(iStr) // ": vel(2) must not be set when n = 0") + & %vel(2), 0._wp)) .and. (.not. mhd), "Patch " // trim(iStr) // ": vel(2) must not be set when n = 0") @:PROHIBIT(n > 0 .and. f_is_default(patch_icpp(patch_id)%vel(2)), "Patch "//trim(iStr)//": vel(2) must be set when n > 0") @:PROHIBIT(p == 0 .and. (.not. f_is_default(patch_icpp(patch_id)%vel(3))) .and. (.not. f_approx_equal(patch_icpp(patch_id) & - & %vel(3), 0._wp)) .and. (.not. mhd), "Patch " // trim(iStr) // ": vel(3) must not be set when p = 0") + & %vel(3), 0._wp)) .and. (.not. mhd), "Patch " // trim(iStr) // ": vel(3) must not be set when p = 0") @:PROHIBIT(p > 0 .and. f_is_default(patch_icpp(patch_id)%vel(3)), "Patch "//trim(iStr)//": vel(3) must be set when p > 0") @:PROHIBIT(mhd .and. (f_is_default(patch_icpp(patch_id)%vel(2)) .or. f_is_default(patch_icpp(patch_id)%vel(3))), & - & "Patch " // trim(iStr) // ": All velocities (vel(1:3)) must be set when mhd = true") + & "Patch " // trim(iStr) // ": All velocities (vel(1:3)) must be set when mhd = true") @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%rho <= 0._wp, & - & "Patch " // trim(iStr) // ": rho must be greater than zero when model_eqns = 1") + & "Patch " // trim(iStr) // ": rho must be greater than zero when model_eqns = 1") @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%gamma <= 0._wp, & - & "Patch " // trim(iStr) // ": gamma must be greater than zero when model_eqns = 1") + & "Patch " // trim(iStr) // ": gamma must be greater than zero when model_eqns = 1") @:PROHIBIT(model_eqns == 1 .and. patch_icpp(patch_id)%pi_inf < 0._wp, & - & "Patch " // trim(iStr) // ": pi_inf must be greater than or equal to zero when model_eqns = 1") + & "Patch " // trim(iStr) // ": pi_inf must be greater than or equal to zero when model_eqns = 1") @:PROHIBIT(patch_icpp(patch_id)%geometry == 5 .and. patch_icpp(patch_id)%pi_inf > 0, & - & "Patch " // trim(iStr) // ": pi_inf must be less than or equal to zero when geometry = 5") + & "Patch " // trim(iStr) // ": pi_inf must be less than or equal to zero when geometry = 5") @:PROHIBIT(model_eqns == 2 .and. any(patch_icpp(patch_id)%alpha_rho(1:num_fluids) < 0._wp), & - & "Patch " // trim(iStr) // ": alpha_rho(1:num_fluids) must be greater than or equal to zero when model_eqns = 2") + & "Patch " // trim(iStr) & + & // ": alpha_rho(1:num_fluids) must be greater than or equal to zero when model_eqns = 2") is_set_B(1) = .not. f_is_default(patch_icpp(patch_id)%Bx) is_set_B(2) = .not. f_is_default(patch_icpp(patch_id)%By) @@ -450,45 +509,52 @@ contains if (model_eqns == 2 .and. num_fluids < num_fluids_max) then @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho(num_fluids + 1:)), & - & "Patch " // trim(iStr) // ": alpha_rho(i) must not be set for i > num_fluids") + & "Patch " // trim(iStr) // ": alpha_rho(i) must not be set for i > num_fluids") @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha(num_fluids + 1:)), & - & "Patch " // trim(iStr) // ": alpha(i) must not be set for i > num_fluids") + & "Patch " // trim(iStr) // ": alpha(i) must not be set for i > num_fluids") @:PROHIBIT(f_is_default(patch_icpp(patch_id)%alpha(num_fluids)), & - & "Patch " // trim(iStr) // ": alpha(num_fluids) must be set") + & "Patch " // trim(iStr) // ": alpha(num_fluids) must be set") end if if (chemistry) then !@:ASSERT(all(patch_icpp(patch_id)%Y(1:num_species) >= 0._wp), "Patch " // trim(iStr) // ".") !@:ASSERT(any(patch_icpp(patch_id)%Y(1:num_species) > verysmall), "Patch " // trim(iStr) // ".") end if + end subroutine s_check_active_patch_primitive_variables !> This subroutine verifies that the primitive variables associated with the given inactive patch remain unaltered by the user !! inputs. !! @param patch_id Patch identifier impure subroutine s_check_inactive_patch_primitive_variables(patch_id) + integer, intent(in) :: patch_id + call s_int_to_str(patch_id, iStr) @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha_rho), & - & "Inactive patch " // trim(iStr) // ": alpha_rho must not be set") + & "Inactive patch " // trim(iStr) // ": alpha_rho must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%rho), "Inactive patch "//trim(iStr)//": rho must not be set") @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%vel), "Inactive patch "//trim(iStr)//": vel must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%pres), "Inactive patch "//trim(iStr)//": pres must not be set") @:PROHIBIT(.not. f_all_default(patch_icpp(patch_id)%alpha), "Inactive patch "//trim(iStr)//": alpha must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%gamma), "Inactive patch "//trim(iStr)//": gamma must not be set") @:PROHIBIT(.not. f_is_default(patch_icpp(patch_id)%pi_inf), "Inactive patch "//trim(iStr)//": pi_inf must not be set") + end subroutine s_check_inactive_patch_primitive_variables !> @brief Verifies that the model file referenced by the given patch exists on disk. impure subroutine s_check_model_geometry(patch_id) + integer, intent(in) :: patch_id logical :: file_exists inquire (file=patch_icpp(patch_id)%model_filepath, exist=file_exists) @:PROHIBIT(.not. file_exists, & - & "Model file " // trim(patch_icpp(patch_id)%model_filepath) // " requested by patch " // trim(iStr) & - & // " does not exist") + & "Model file " // trim(patch_icpp(patch_id)%model_filepath) // " requested by patch " // trim(iStr) & + & // " does not exist") + end subroutine s_check_model_geometry + end module m_check_patches diff --git a/src/pre_process/m_checker.fpp b/src/pre_process/m_checker.fpp index b588dcca1c..bfd47ff473 100644 --- a/src/pre_process/m_checker.fpp +++ b/src/pre_process/m_checker.fpp @@ -6,17 +6,21 @@ !> @brief Checks pre-process input file parameters for compatibility and correctness module m_checker + use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none private; public :: s_check_inputs + contains !> Checks compatibility of parameters in the input file. Used by the pre_process stage impure subroutine s_check_inputs + end subroutine s_check_inputs + end module m_checker diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index faf22ee2eb..6f27125408 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -4,10 +4,11 @@ !> @brief Writes grid and initial condition data to serial or parallel output files module m_data_output - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code use m_helper - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif @@ -34,11 +35,13 @@ module m_data_output !> Interface for the conservative data !! @param q_cons_vf Conservative variables impure subroutine s_write_abstract_data_files(q_cons_vf, q_prim_vf, bc_type) + import :: scalar_field, integer_field, sys_size, m, n, p, pres_field, num_dims ! Conservative variables type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type + end subroutine s_write_abstract_data_files end interface @@ -46,13 +49,15 @@ module m_data_output character(LEN=path_len + 2*name_len), private :: t_step_dir character(LEN=path_len + 2*name_len), public :: restart_dir !< Restart data folder procedure(s_write_abstract_data_files), pointer :: s_write_data_files => null() + contains - !> Writes grid and initial condition data files to the "0" time-step directory in the local processor rank folder - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Primitive variables - !! @param bc_type Boundary condition types + !> Writes grid and initial condition data files to the "0" time-step directory in the local processor rank folder + !! @param q_cons_vf Conservative variables + !! @param q_prim_vf Primitive variables + !! @param bc_type Boundary condition types impure subroutine s_write_serial_data_files(q_cons_vf, q_prim_vf, bc_type) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf ! BC types @@ -62,16 +67,16 @@ contains character(LEN=3) :: status !> Used to store the number, in character form, of the currently manipulated conservative variable data file character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num - character(LEN=len_trim(t_step_dir) + name_len) :: file_loc !< Generic string used to store the address of a particular file - integer :: i, j, k, l, r, c !< Generic loop iterator - integer :: t_step - real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration - real(wp) :: nbub !< Temporary bubble number density - real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params - real(wp) :: rho !< Temporary density - real(wp) :: pres, T !< Temporary pressure - real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions - real(wp) :: pres_mag + character(LEN=len_trim(t_step_dir) + name_len) :: file_loc !< Generic string used to store the address of a particular file + integer :: i, j, k, l, r, c !< Generic loop iterator + integer :: t_step + real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration + real(wp) :: nbub !< Temporary bubble number density + real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params + real(wp) :: rho !< Temporary density + real(wp) :: pres, T !< Temporary pressure + real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions + real(wp) :: pres_mag pres_mag = 0._wp @@ -191,7 +196,7 @@ contains if ((i >= chemxb) .and. (i <= chemxe)) then write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0)/rho else if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) .or. ((i >= adv_idx%beg) .and. (i <= adv_idx%end) & - & ) .or. ((i >= chemxb) .and. (i <= chemxe))) then + & ) .or. ((i >= chemxb) .and. (i <= chemxe))) then write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0) else if (i == mom_idx%beg) then ! u write (2, FMT) x_cb(j), q_cons_vf(mom_idx%beg)%sf(j, 0, 0)/rho @@ -200,12 +205,12 @@ contains else if (i == E_idx) then ! p if (mhd) then pres_mag = 0.5_wp*(Bx0**2 + q_cons_vf(B_idx%beg)%sf(j, 0, 0)**2 + q_cons_vf(B_idx%beg + 1)%sf(j, & - & 0, 0)**2) + & 0, 0)**2) end if call s_compute_pressure(q_cons_vf(E_idx)%sf(j, 0, 0), q_cons_vf(alf_idx)%sf(j, 0, 0), & - & 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, 0, 0)**2._wp)/rho, pi_inf, gamma, rho, qv, rhoYks, pres, & - & T, pres_mag=pres_mag) + & 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, 0, 0)**2._wp)/rho, pi_inf, gamma, rho, & + & qv, rhoYks, pres, T, pres_mag=pres_mag) write (2, FMT) x_cb(j), pres else if (mhd) then if (i == mom_idx%beg + 1) then ! v @@ -256,7 +261,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -268,7 +273,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -304,7 +309,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -318,7 +323,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -359,7 +364,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -375,7 +380,7 @@ contains do i = 1, nb do r = 1, nnode write (file_loc, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_loc)) do j = 0, m @@ -390,13 +395,15 @@ contains end do end if end if + end subroutine s_write_serial_data_files - !> Writes grid and initial condition data files in parallel to the "0" time-step directory in the local processor rank folder - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Primitive variables - !! @param bc_type Boundary condition types + !> Writes grid and initial condition data files in parallel to the "0" time-step directory in the local processor rank folder + !! @param q_cons_vf Conservative variables + !! @param q_prim_vf Primitive variables + !! @param bc_type Boundary condition types impure subroutine s_write_parallel_data_files(q_cons_vf, q_prim_vf, bc_type) + ! Conservative variables type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type @@ -601,10 +608,12 @@ contains call s_write_parallel_boundary_condition_files(q_prim_vf, bc_type) end if end if + end subroutine s_write_parallel_data_files - !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_data_output_module + ! Generic string used to store the address of a particular file character(LEN=len_trim(case_dir) + 2*name_len) :: file_loc character(len=15) :: temp @@ -614,16 +623,15 @@ contains logical :: dir_check integer :: i integer :: m_ds, n_ds, p_ds !< down sample dimensions + if (parallel_io .neqv. .true.) then ! Setting the address of the time-step directory write (t_step_dir, '(A,I0,A)') '/p_all/p', proc_rank, '/0' t_step_dir = trim(case_dir) // trim(t_step_dir) - ! Checking the existence of the time-step directory, removing it, if - ! it exists, and creating a new copy. Note that if preexisting grid - ! and/or initial condition data are to be read in from the very same - ! location, then the above described steps are not executed here but - ! rather in the module m_start_up.f90. + ! Checking the existence of the time-step directory, removing it, if it exists, and creating a new copy. Note that if + ! preexisting grid and/or initial condition data are to be read in from the very same location, then the above described + ! steps are not executed here but rather in the module m_start_up.f90. if (old_grid .neqv. .true.) then file_loc = trim(t_step_dir) // '/' @@ -662,7 +670,7 @@ contains do i = contxb, contxe write (temp, '(I0)') i - contxb + 1 write (1, '(I3,A20,A20)') i, "\alpha_{" // trim(temp) // "} \rho_{" // trim(temp) // "}", & - & "\alpha_{" // trim(temp) // "} \rho" + & "\alpha_{" // trim(temp) // "} \rho" end do do i = momxb, momxe write (1, '(I3,A20,A20)') i, "\rho u_" // coord(i - momxb + 1), "u_" // coord(i - momxb + 1) @@ -677,7 +685,7 @@ contains if (chemistry) then do i = 1, num_species write (1, '(I3,A20,A20)') chemxb + i - 1, "Y_{" // trim(species_names(i)) // "} \rho", & - & "Y_{" // trim(species_names(i)) // "}" + & "Y_{" // trim(species_names(i)) // "}" end do end if @@ -703,10 +711,12 @@ contains allocate (q_cons_temp(i)%sf(-1:m_ds + 1, -1:n_ds + 1, -1:p_ds + 1)) end do end if + end subroutine s_initialize_data_output_module !> Resets s_write_data_files pointer impure subroutine s_finalize_data_output_module + integer :: i s_write_data_files => null() @@ -717,5 +727,7 @@ contains end do deallocate (q_cons_temp) end if + end subroutine s_finalize_data_output_module + end module m_data_output diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 28ac47c835..5d134c167a 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -6,6 +6,7 @@ !> @brief Defines global parameters for the computational domain, simulation algorithm, and initial conditions module m_global_parameters + #ifdef MFC_MPI use mpi ! Message passing interface (MPI) module #endif @@ -44,13 +45,12 @@ module m_global_parameters real(wp), allocatable, dimension(:) :: x_cc, y_cc, z_cc !> Locations of cell-boundaries (cb) in x-, y- and z-directions, respectively real(wp), allocatable, dimension(:) :: x_cb, y_cb, z_cb - real(wp) :: dx, dy, dz !< Minimum cell-widths in the x-, y- and z-coordinate directions - type(bounds_info) :: x_domain, y_domain, z_domain !< Locations of the domain bounds in the x-, y- and z-coordinate directions - logical :: stretch_x, stretch_y, stretch_z !< Grid stretching flags for the x-, y- and z-coordinate directions - ! Parameters of the grid stretching function for the x-, y- and z-coordinate - ! directions. The "a" parameters are a measure of the rate at which the grid - ! is stretched while the remaining parameters are indicative of the location - ! on the grid at which the stretching begins. + real(wp) :: dx, dy, dz !< Minimum cell-widths in the x-, y- and z-coordinate directions + type(bounds_info) :: x_domain, y_domain, z_domain !< Locations of the domain bounds in the x-, y- and z-coordinate directions + logical :: stretch_x, stretch_y, stretch_z !< Grid stretching flags for the x-, y- and z-coordinate directions + ! Parameters of the grid stretching function for the x-, y- and z-coordinate directions. The "a" parameters are a measure of the + ! rate at which the grid is stretched while the remaining parameters are indicative of the location on the grid at which the + ! stretching begins. real(wp) :: a_x, a_y, a_z integer :: loops_x, loops_y, loops_z real(wp) :: x_a, y_a, z_a @@ -101,13 +101,11 @@ module m_global_parameters type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. integer :: damage_idx !< Index of damage state variable (D) for continuum damage model integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD - ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). - ! Stands for "InDices With BUFFer". + ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). Stands for "InDices With BUFFer". type(int_bounds_info) :: idwint(1:3) - ! Cell Indices for the entire (local) domain. In simulation and post_process, - ! this includes the buffer region. idwbuff and idwint are the same otherwise. - ! Stands for "InDices With BUFFer". + ! Cell Indices for the entire (local) domain. In simulation and post_process, this includes the buffer region. idwbuff and + ! idwint are the same otherwise. Stands for "InDices With BUFFer". type(int_bounds_info) :: idwbuff(1:3) type(int_bounds_info) :: bc_x, bc_y, bc_z !< Boundary conditions in the x-, y- and z-coordinate directions integer :: shear_num !! Number of shear stress components @@ -160,8 +158,8 @@ module m_global_parameters integer :: num_bc_patches !< Number of boundary condition patches logical :: bc_io !< whether or not to save BC data type(bc_patch_parameters), dimension(num_bc_patches_max) :: patch_bc - !! Database of the boundary condition patch parameters for each of the patches - !! employed in the configuration of the boundary conditions + !! Database of the boundary condition patch parameters for each of the patches employed in the configuration of the boundary + !! conditions ! Fluids Physical Parameters !> Database of the physical parameters of each of the fluids that is present in the flow. These include the stiffened gas @@ -190,26 +188,23 @@ module m_global_parameters integer :: Np type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l - !! Database of the immersed boundary patch parameters for each of the - !! patches employed in the configuration of the initial condition. Note that - !! the maximum allowable number of patches, num_patches_max, may be changed - !! in the module m_derived_types.f90. - + !! Database of the immersed boundary patch parameters for each of the patches employed in the configuration of the initial + !! condition. Note that the maximum allowable number of patches, num_patches_max, may be changed in the module + !! m_derived_types.f90. !> @} !> @name Non-polytropic bubble gas compression !> @{ - logical :: polytropic - logical :: polydisperse - real(wp) :: poly_sigma - integer :: dist_type ! 1 = binormal, 2 = lognormal-normal - integer :: thermal ! 1 = adiabatic, 2 = isotherm, 3 = transfer - real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl - real(wp) :: gam_m + logical :: polytropic + logical :: polydisperse + real(wp) :: poly_sigma + integer :: dist_type ! 1 = binormal, 2 = lognormal-normal + integer :: thermal ! 1 = adiabatic, 2 = isotherm, 3 = transfer + real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl + real(wp) :: gam_m real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g real(wp), dimension(:), allocatable :: Re_trans_T, Re_trans_c, Im_trans_T, Im_trans_c, omegaN - real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g - + real(wp) :: R0ref, p0ref, rho0ref, T0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, cp_v, cp_g, R_v, R_g !> @} !> @name Surface Tension Modeling @@ -241,13 +236,16 @@ module m_global_parameters !> AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional !! is false logical :: dummy + contains !> Assigns default values to user inputs prior to reading them in. This allows for an easier consistency check of these !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs + integer :: i !< Generic loop operator ! Logistics + case_dir = '.' old_grid = .false. old_ic = .false. @@ -563,10 +561,12 @@ contains bub_pp%cp_g = dflt_real; cp_g = dflt_real bub_pp%R_v = dflt_real; R_v = dflt_real bub_pp%R_g = dflt_real; R_g = dflt_real + end subroutine s_assign_default_values_to_user_inputs !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_global_parameters_module + integer :: i, j, fac if (recon_type == WENO_TYPE) then @@ -575,18 +575,16 @@ contains muscl_polyn = muscl_order end if - ! Determining the layout of the state vectors and overall size of - ! the system of equations, given the dimensionality and choice of - ! the equations of motion + ! Determining the layout of the state vectors and overall size of the system of equations, given the dimensionality and + ! choice of the equations of motion ! Gamma/Pi_inf Model if (model_eqns == 1) then ! Setting number of fluids num_fluids = 1 - ! Annotating structure of the state and flux vectors belonging - ! to the system of equations defined by the selected number of - ! spatial dimensions and the gamma/pi_inf model + ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number + ! of spatial dimensions and the gamma/pi_inf model cont_idx%beg = 1 cont_idx%end = cont_idx%beg mom_idx%beg = cont_idx%end + 1 @@ -600,9 +598,8 @@ contains ! Volume Fraction Model (5-equation model) else if (model_eqns == 2) then - ! Annotating structure of the state and flux vectors belonging - ! to the system of equations defined by the selected number of - ! spatial dimensions and the volume fraction model + ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number + ! of spatial dimensions and the volume fraction model cont_idx%beg = 1 cont_idx%end = num_fluids mom_idx%beg = cont_idx%end + 1 @@ -610,17 +607,14 @@ contains E_idx = mom_idx%end + 1 if (igr) then - ! Volume fractions are stored in the indices immediately following - ! the energy equation. IGR tracks a total of (N-1) volume fractions - ! for N fluids, hence the "-1" in adv_idx%end. If num_fluids = 1 - ! then adv_idx%end < adv_idx%beg, which skips all loops over the - ! volume fractions since there is no volume fraction to track + ! Volume fractions are stored in the indices immediately following the energy equation. IGR tracks a total of (N-1) + ! volume fractions for N fluids, hence the "-1" in adv_idx%end. If num_fluids = 1 then adv_idx%end < adv_idx%beg, + ! which skips all loops over the volume fractions since there is no volume fraction to track adv_idx%beg = E_idx + 1 adv_idx%end = E_idx + num_fluids - 1 else - ! Volume fractions are stored in the indices immediately following - ! the energy equation. WENO/MUSCL + Riemann tracks a total of (N) - ! volume fractions for N fluids, hence the lack of "-1" in adv_idx%end + ! Volume fractions are stored in the indices immediately following the energy equation. WENO/MUSCL + Riemann tracks + ! a total of (N) volume fractions for N fluids, hence the lack of "-1" in adv_idx%end adv_idx%beg = E_idx + 1 adv_idx%end = E_idx + num_fluids end if @@ -704,9 +698,8 @@ contains ! Volume Fraction Model (6-equation model) else if (model_eqns == 3) then - ! Annotating structure of the state and flux vectors belonging - ! to the system of equations defined by the selected number of - ! spatial dimensions and the volume fraction model + ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number + ! of spatial dimensions and the volume fraction model cont_idx%beg = 1 cont_idx%end = num_fluids mom_idx%beg = cont_idx%end + 1 @@ -796,9 +789,7 @@ contains shear_BC_flip_indices(1, 1:2) = shear_indices((/1, 2/)) shear_BC_flip_indices(2, 1:2) = shear_indices((/1, 3/)) shear_BC_flip_indices(3, 1:2) = shear_indices((/2, 3/)) - ! x-dir: flip tau_xy and tau_xz - ! y-dir: flip tau_xy and tau_yz - ! z-dir: flip tau_xz and tau_yz + ! x-dir: flip tau_xy and tau_xz y-dir: flip tau_xy and tau_yz z-dir: flip tau_xz and tau_yz end if end if @@ -852,7 +843,7 @@ contains chemxe = species_idx%end call s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & - & bubbles_lagrange, m, n, p, num_dims, igr, ib) + & bubbles_lagrange, m, n, p, num_dims, igr, ib) #ifdef MFC_MPI @@ -899,10 +890,12 @@ contains if (.not. igr) then allocate (logic_grid(0:m, 0:n, 0:p)) end if + end subroutine s_initialize_global_parameters_module !> @brief Configures MPI parallel I/O settings and allocates processor coordinate arrays. impure subroutine s_initialize_parallel_io + #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors #endif @@ -927,20 +920,21 @@ contains call MPI_INFO_CREATE(mpi_info_int, ierr) call MPI_INFO_SET(mpi_info_int, 'romio_ds_write', 'disable', ierr) - ! Option for UNIX file system (Hooke/Thomson) - ! WRITE(mpiiofs, '(A)') '/ufs_' - ! mpiiofs = TRIM(mpiiofs) - ! mpi_info_int = MPI_INFO_NULL + ! Option for UNIX file system (Hooke/Thomson) WRITE(mpiiofs, '(A)') '/ufs_' mpiiofs = TRIM(mpiiofs) mpi_info_int = + ! MPI_INFO_NULL allocate (start_idx(1:num_dims)) #endif + end subroutine s_initialize_parallel_io !> @brief Deallocates all global grid, index, and equation-of-state parameter arrays. impure subroutine s_finalize_global_parameters_module + integer :: i ! Deallocating grid variables for the x-direction + deallocate (x_cc, x_cb) ! Deallocating grid variables for the y- and z-directions if (n > 0) then @@ -964,5 +958,7 @@ contains deallocate (MPI_IO_DATA%view) end if #endif + end subroutine s_finalize_global_parameters_module + end module m_global_parameters diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index c24969c140..d893ba2171 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -4,6 +4,7 @@ !> @brief Generates uniform or stretched rectilinear grids with hyperbolic-tangent spacing module m_grid + use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code use m_mpi_proxy ! Message passing interface (MPI) module proxy @@ -21,20 +22,24 @@ module m_grid !> @brief Abstract interface for generating a rectilinear computational grid. impure subroutine s_generate_abstract_grid + end subroutine s_generate_abstract_grid end interface procedure(s_generate_abstract_grid), pointer :: s_generate_grid => null() + contains !> The following subroutine generates either a uniform or non-uniform rectilinear grid in serial, defined by the parameters !! inputted by the user. The grid information is stored in the grid variables containing coordinates of the cell- centers and !! cell-boundaries. impure subroutine s_generate_serial_grid + ! Generic loop iterator integer :: i, j !< generic loop operators real(wp) :: length !< domain lengths ! Grid Generation in the x-direction + dx = (x_domain%end - x_domain%beg)/real(m + 1, wp) do i = 0, m @@ -53,7 +58,7 @@ impure subroutine s_generate_serial_grid do j = 1, loops_x do i = -1, m x_cb(i) = x_cb(i)/a_x*(a_x + log(cosh(a_x*(x_cb(i) - x_a))) + log(cosh(a_x*(x_cb(i) - x_b))) & - & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) + & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) end do end do x_cb = x_cb*length @@ -100,7 +105,7 @@ impure subroutine s_generate_serial_grid do j = 1, loops_y do i = -1, n y_cb(i) = y_cb(i)/a_y*(a_y + log(cosh(a_y*(y_cb(i) - y_a))) + log(cosh(a_y*(y_cb(i) - y_b))) & - & - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) + & - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) end do end do @@ -133,7 +138,7 @@ impure subroutine s_generate_serial_grid do j = 1, loops_z do i = -1, p z_cb(i) = z_cb(i)/a_z*(a_z + log(cosh(a_z*(z_cb(i) - z_a))) + log(cosh(a_z*(z_cb(i) - z_b))) & - & - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) + & - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) end do end do @@ -144,12 +149,14 @@ impure subroutine s_generate_serial_grid if (num_procs > 1) call s_mpi_reduce_min(dz) end if + end subroutine s_generate_serial_grid !> The following subroutine generates either a uniform or non-uniform rectilinear grid in parallel, defined by the parameters !! inputted by the user. The grid information is stored in the grid variables containing coordinates of the cell- centers and !! cell-boundaries. impure subroutine s_generate_parallel_grid + #ifdef MFC_MPI real(wp) :: length !< domain lengths @@ -159,6 +166,7 @@ impure subroutine s_generate_parallel_grid integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status integer :: i, j !< Generic loop integers + allocate (x_cb_glb(-1:m_glb)) allocate (y_cb_glb(-1:n_glb)) allocate (z_cb_glb(-1:p_glb)) @@ -180,7 +188,7 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_x do i = -1, m_glb x_cb_glb(i) = x_cb_glb(i)/a_x*(a_x + log(cosh(a_x*(x_cb_glb(i) - x_a))) + log(cosh(a_x*(x_cb_glb(i) - x_b))) & - & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) + & - 2._wp*log(cosh(a_x*(x_b - x_a)/2._wp))) end do end do @@ -213,7 +221,7 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_y do i = -1, n_glb y_cb_glb(i) = y_cb_glb(i)/a_y*(a_y + log(cosh(a_y*(y_cb_glb(i) - y_a))) + log(cosh(a_y*(y_cb_glb(i) - y_b) & - & )) - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) + & )) - 2._wp*log(cosh(a_y*(y_b - y_a)/2._wp))) end do end do @@ -237,7 +245,7 @@ impure subroutine s_generate_parallel_grid do j = 1, loops_z do i = -1, p_glb z_cb_glb(i) = z_cb_glb(i)/a_z*(a_z + log(cosh(a_z*(z_cb_glb(i) - z_a))) + log(cosh(a_z*(z_cb_glb(i) & - & - z_b))) - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) + & - z_b))) - 2._wp*log(cosh(a_z*(z_b - z_a)/2._wp))) end do end do @@ -271,19 +279,25 @@ impure subroutine s_generate_parallel_grid deallocate (x_cb_glb, y_cb_glb, z_cb_glb) #endif + end subroutine s_generate_parallel_grid - !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_grid_module + if (parallel_io .neqv. .true.) then s_generate_grid => s_generate_serial_grid else s_generate_grid => s_generate_parallel_grid end if + end subroutine s_initialize_grid_module !> Deallocation procedures for the module impure subroutine s_finalize_grid_module + s_generate_grid => null() + end subroutine s_finalize_grid_module + end module m_grid diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 6bc2d2c115..f3d98a3e67 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -11,11 +11,12 @@ !> @brief Constructs initial condition patch geometries (lines, circles, rectangles, spheres, etc.) on the grid module m_icpp_patches + use m_model ! Subroutine(s) related to STL files use m_derived_types ! Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_constants, only: max_2d_fourier_modes, max_sph_harm_degree, small_radius - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper use m_mpi_common use m_assign_variables @@ -45,10 +46,12 @@ module m_icpp_patches !! necessary to lay out a particular patch on the grid. type(bounds_info) :: x_boundary, y_boundary, z_boundary character(len=5) :: istr ! string to store int to string result for error checking + contains !> @brief Dispatches each initial condition patch to its geometry-specific initialization routine. impure subroutine s_apply_icpp_patches(patch_id_fp, q_prim_vf) + type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -58,6 +61,7 @@ contains integer :: i ! 3D Patch Geometries + if (p > 0) then do i = 1, num_patches if (proc_rank == 0) then @@ -118,7 +122,7 @@ contains ! Unimplemented patch (formerly isentropic vortex) else if (patch_icpp(i)%geometry == 6) then call s_mpi_abort('This used to be the isentropic vortex patch, ' & - & // 'which no longer exists. See Examples. Exiting.') + & // 'which no longer exists. See Examples. Exiting.') ! 2D modal (Fourier) patch else if (patch_icpp(i)%geometry == 13) then call s_icpp_2d_modal(i, patch_id_fp, q_prim_vf) @@ -155,6 +159,7 @@ contains end if end do end if + end subroutine s_apply_icpp_patches !> The line segment patch is a 1D geometry that may be used, for example, in creating a Riemann problem. The geometry of the @@ -164,6 +169,7 @@ contains !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_line_segment(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -177,6 +183,7 @@ contains ! Placeholders for the cell boundary values real(wp) :: pi_inf, gamma, lit_gamma + @:HardcodedDimensionsExtrusion() @:Hardcoded1DVariables() @@ -190,21 +197,17 @@ contains x_centroid = patch_icpp(patch_id)%x_centroid length_x = patch_icpp(patch_id)%length_x - ! Computing the beginning and end x-coordinates of the line segment - ! based on its centroid and length + ! Computing the beginning and end x-coordinates of the line segment based on its centroid and length x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x - ! Since the line segment patch does not allow for its boundaries to - ! be smoothed out, the pseudo volume fraction is set to 1 to ensure - ! that only the current patch contributes to the fluid state in the - ! cells that this patch covers. + ! Since the line segment patch does not allow for its boundaries to be smoothed out, the pseudo volume fraction is set to 1 + ! to ensure that only the current patch contributes to the fluid state in the cells that this patch covers. eta = 1._wp - ! Checking whether the line segment covers a particular cell in the - ! domain and verifying whether the current patch has the permission - ! to write to that cell. If both queries check out, the primitive - ! variables of the current patch are assigned to this cell. + ! Checking whether the line segment covers a particular cell in the domain and verifying whether the current patch has the + ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to + ! this cell. do i = 0, m if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, & & 0, 0))) then @@ -222,14 +225,16 @@ contains end if end do @:HardcodedDellacation() + end subroutine s_icpp_line_segment !> The spiral patch is a 2D geometry that may be used, The geometry of the patch is well-defined when its centroid and radius !! are provided. Note that the circular patch DOES allow for the smoothing of its boundary. - !! @param patch_id patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables impure subroutine s_icpp_spiral(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -240,11 +245,11 @@ contains integer :: i, j, k !< Generic loop iterators real(wp) :: th, thickness, nturns, mya real(wp) :: spiral_x_min, spiral_x_max, spiral_y_min, spiral_y_max + @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() - ! Transferring the circular patch's radius, centroid, smearing patch - ! identity and smearing coefficient information + ! Transferring the circular patch's radius, centroid, smearing patch identity and smearing coefficient information x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid mya = patch_icpp(patch_id)%radius @@ -286,15 +291,17 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_spiral !> The circular patch is a 2D geometry that may be used, for example, in creating a bubble or a droplet. The geometry of the !! patch is well-defined when its centroid and radius are provided. Note that the circular patch DOES allow for the smoothing of !! its boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_circle(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -304,11 +311,11 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf real(wp) :: radius integer :: i, j, k !< Generic loop iterators + @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() - ! Transferring the circular patch's radius, centroid, smearing patch - ! identity and smearing coefficient information + ! Transferring the circular patch's radius, centroid, smearing patch identity and smearing coefficient information x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid @@ -316,21 +323,18 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Initializing the pseudo volume fraction value to 1. The value will - ! be modified as the patch is laid out on the grid, but only in the - ! case that smoothing of the circular patch's boundary is enabled. + ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but + ! only in the case that smoothing of the circular patch's boundary is enabled. eta = 1._wp - ! Checking whether the circle covers a particular cell in the domain - ! and verifying whether the current patch has permission to write to - ! that cell. If both queries check out, the primitive variables of - ! the current patch are assigned to this cell. + ! Checking whether the circle covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. do j = 0, n do i = 0, m if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, & - & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp + & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp end if if (((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2 <= radius**2 .and. patch_icpp(patch_id) & @@ -345,13 +349,15 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_circle - !> The varcircle patch is a 2D geometry that may be used . It generatres an annulus - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !> The varcircle patch is a 2D geometry that may be used . It generatres an annulus + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_varcircle(patch_id, patch_id_fp, q_prim_vf) + ! Patch identifier integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION @@ -364,11 +370,11 @@ contains ! Generic loop iterators integer :: i, j, k real(wp) :: radius, myr, thickness + @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() - ! Transferring the circular patch's radius, centroid, smearing patch - ! identity and smearing coefficient information + ! Transferring the circular patch's radius, centroid, smearing patch identity and smearing coefficient information x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid radius = patch_icpp(patch_id)%radius @@ -376,15 +382,12 @@ contains smooth_coeff = patch_icpp(patch_id)%smooth_coeff thickness = patch_icpp(patch_id)%epsilon - ! Initializing the pseudo volume fraction value to 1. The value will - ! be modified as the patch is laid out on the grid, but only in the - ! case that smoothing of the circular patch's boundary is enabled. + ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but + ! only in the case that smoothing of the circular patch's boundary is enabled. eta = 1._wp - ! Checking whether the circle covers a particular cell in the domain - ! and verifying whether the current patch has permission to write to - ! that cell. If both queries check out, the primitive variables of - ! the current patch are assigned to this cell. + ! Checking whether the circle covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. do j = 0, n do i = 0, m myr = sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) @@ -402,11 +405,12 @@ contains if (1._wp - eta < sgm_eps) patch_id_fp(i, j, 0) = patch_id q_prim_vf(alf_idx)%sf(i, j, & - & 0) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) + & 0) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) end if end do end do @:HardcodedDellacation() + end subroutine s_icpp_varcircle !> @brief Initializes a 3D variable-thickness circular annulus patch extruded along the z-axis. @@ -414,6 +418,7 @@ contains !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Array of primitive variables subroutine s_icpp_3dvarcircle(patch_id, patch_id_fp, q_prim_vf) + ! Patch identifier integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION @@ -426,11 +431,11 @@ contains ! Generic loop iterators integer :: i, j, k real(wp) :: radius, myr, thickness + @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() - ! Transferring the circular patch's radius, centroid, smearing patch - ! identity and smearing coefficient information + ! Transferring the circular patch's radius, centroid, smearing patch identity and smearing coefficient information x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid z_centroid = patch_icpp(patch_id)%z_centroid @@ -440,17 +445,14 @@ contains smooth_coeff = patch_icpp(patch_id)%smooth_coeff thickness = patch_icpp(patch_id)%epsilon - ! Initializing the pseudo volume fraction value to 1. The value will - ! be modified as the patch is laid out on the grid, but only in the - ! case that smoothing of the circular patch's boundary is enabled. + ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but + ! only in the case that smoothing of the circular patch's boundary is enabled. eta = 1._wp ! write for all z - ! Checking whether the circle covers a particular cell in the domain - ! and verifying whether the current patch has permission to write to - ! that cell. If both queries check out, the primitive variables of - ! the current patch are assigned to this cell. + ! Checking whether the circle covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. do k = 0, p do j = 0, n do i = 0, m @@ -469,20 +471,22 @@ contains if (1._wp - eta < sgm_eps) patch_id_fp(i, j, k) = patch_id q_prim_vf(alf_idx)%sf(i, j, & - & k) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) + & k) = patch_icpp(patch_id)%alpha(1)*exp(-0.5_wp*((myr - radius)**2._wp)/(thickness/3._wp)**2._wp) end if end do end do end do @:HardcodedDellacation() + end subroutine s_icpp_3dvarcircle !> The elliptical patch is a 2D geometry. The geometry of the patch is well-defined when its centroid and radii are provided. !! Note that the elliptical patch DOES allow for the smoothing of its boundary - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_ellipse(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -492,11 +496,11 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop operators real(wp) :: a, b + @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() - ! Transferring the elliptical patch's radii, centroid, smearing - ! patch identity, and smearing coefficient information + ! Transferring the elliptical patch's radii, centroid, smearing patch identity, and smearing coefficient information x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid a = patch_icpp(patch_id)%radii(1) @@ -504,21 +508,18 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Initializing the pseudo volume fraction value to 1. The value - ! be modified as the patch is laid out on the grid, but only in - ! the case that smoothing of the elliptical patch's boundary is - ! enabled. + ! Initializing the pseudo volume fraction value to 1. The value be modified as the patch is laid out on the grid, but only + ! in the case that smoothing of the elliptical patch's boundary is enabled. eta = 1._wp - ! Checking whether the ellipse covers a particular cell in the - ! domain and verifying whether the current patch has permission - ! to write to that cell. If both queries check out, the primitive - ! variables of the current patch are assigned to this cell. + ! Checking whether the ellipse covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. do j = 0, n do i = 0, m if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, & - & dy)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((y_cc(j) - y_centroid)/b)**2) - 1._wp))*(-0.5_wp) + 0.5_wp + & dy)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((y_cc(j) - y_centroid)/b)**2) - 1._wp))*(-0.5_wp) & + & + 0.5_wp end if if ((((x_cc(i) - x_centroid)/a)**2 + ((y_cc(j) - y_centroid)/b)**2 <= 1._wp .and. patch_icpp(patch_id) & @@ -536,14 +537,16 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_ellipse !> The ellipsoidal patch is a 3D geometry. The geometry of the patch is well-defined when its centroid and radii are provided. !! Note that the ellipsoidal patch DOES allow for the smoothing of its boundary - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_ellipsoid(patch_id, patch_id_fp, q_prim_vf) + ! Patch identifier integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION @@ -556,11 +559,11 @@ contains ! Generic loop iterators integer :: i, j, k real(wp) :: a, b, c + @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() - ! Transferring the ellipsoidal patch's radii, centroid, smearing - ! patch identity, and smearing coefficient information + ! Transferring the ellipsoidal patch's radii, centroid, smearing patch identity, and smearing coefficient information x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid z_centroid = patch_icpp(patch_id)%z_centroid @@ -570,16 +573,13 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Initializing the pseudo volume fraction value to 1. The value - ! be modified as the patch is laid out on the grid, but only in - ! the case that smoothing of the ellipsoidal patch's boundary is - ! enabled. + ! Initializing the pseudo volume fraction value to 1. The value be modified as the patch is laid out on the grid, but only + ! in the case that smoothing of the ellipsoidal patch's boundary is enabled. eta = 1._wp - ! Checking whether the ellipsoid covers a particular cell in the - ! domain and verifying whether the current patch has permission - ! to write to that cell. If both queries check out, the primitive - ! variables of the current patch are assigned to this cell. + ! Checking whether the ellipsoid covers a particular cell in the domain and verifying whether the current patch has + ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to + ! this cell. do k = 0, p do j = 0, n do i = 0, m @@ -592,8 +592,8 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, dy, & - & dz)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((cart_y - y_centroid)/b)**2 + ((cart_z - z_centroid)/c) & - & **2) - 1._wp))*(-0.5_wp) + 0.5_wp + & dz)*(sqrt(((x_cc(i) - x_centroid)/a)**2 + ((cart_y - y_centroid)/b)**2 + ((cart_z & + & - z_centroid)/c)**2) - 1._wp))*(-0.5_wp) + 0.5_wp end if if ((((x_cc(i) - x_centroid)/a)**2 + ((cart_y - y_centroid)/b)**2 + ((cart_z - z_centroid)/c) & @@ -613,16 +613,18 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_ellipsoid !> The rectangular patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock !! region, in alignment with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x- and y- coordinate directions are provided. Please note that the rectangular patch DOES NOT !! allow for the smoothing of its boundaries. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_rectangle(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -632,6 +634,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< generic loop iterators real(wp) :: pi_inf, gamma, lit_gamma !< Equation of state parameters + @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -645,23 +648,19 @@ contains length_x = patch_icpp(patch_id)%length_x length_y = patch_icpp(patch_id)%length_y - ! Computing the beginning and the end x- and y-coordinates of the - ! rectangle based on its centroid and lengths + ! Computing the beginning and the end x- and y-coordinates of the rectangle based on its centroid and lengths x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x y_boundary%beg = y_centroid - 0.5_wp*length_y y_boundary%end = y_centroid + 0.5_wp*length_y - ! Since the rectangular patch does not allow for its boundaries to - ! be smoothed out, the pseudo volume fraction is set to 1 to ensure - ! that only the current patch contributes to the fluid state in the - ! cells that this patch covers. + ! Since the rectangular patch does not allow for its boundaries to be smoothed out, the pseudo volume fraction is set to 1 + ! to ensure that only the current patch contributes to the fluid state in the cells that this patch covers. eta = 1._wp - ! Checking whether the rectangle covers a particular cell in the - ! domain and verifying whether the current patch has the permission - ! to write to that cell. If both queries check out, the primitive - ! variables of the current patch are assigned to this cell. + ! Checking whether the rectangle covers a particular cell in the domain and verifying whether the current patch has the + ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to + ! this cell. do j = 0, n do i = 0, m if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. y_boundary%beg <= y_cc(j) & @@ -678,7 +677,8 @@ contains if ((q_prim_vf(1)%sf(i, j, 0) < 1.e-10) .and. (model_eqns == 4)) then ! zero density, reassign according to Tait EOS q_prim_vf(1)%sf(i, j, 0) = (((q_prim_vf(E_idx)%sf(i, j, & - & 0) + pi_inf)/(pref + pi_inf))**(1._wp/lit_gamma))*rhoref*(1._wp - q_prim_vf(alf_idx) %sf(i, j, 0)) + & 0) + pi_inf)/(pref + pi_inf))**(1._wp/lit_gamma))*rhoref*(1._wp - q_prim_vf(alf_idx) & + & %sf(i, j, 0)) end if ! Updating the patch identities bookkeeping variable @@ -688,16 +688,18 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_rectangle !> The swept line patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock !! region, at an angle with respect to the axes of the Cartesian coordinate system. The geometry of the patch is well-defined !! when its centroid and normal vector, aimed in the sweep direction, are provided. Note that the sweep line patch DOES allow !! the smoothing of its boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_sweep_line(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -707,6 +709,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop operators real(wp) :: a, b, c + @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -721,15 +724,13 @@ contains b = patch_icpp(patch_id)%normal(2) c = -a*x_centroid - b*y_centroid - ! Initializing the pseudo volume fraction value to 1. The value will - ! be modified as the patch is laid out on the grid, but only in the - ! case that smoothing of the sweep line patch's boundary is enabled. + ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but + ! only in the case that smoothing of the sweep line patch's boundary is enabled. eta = 1._wp - ! Checking whether the region swept by the line covers a particular - ! cell in the domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, the - ! primitive variables of the current patch are written to this cell. + ! Checking whether the region swept by the line covers a particular cell in the domain and verifying whether the current + ! patch has the permission to write to that cell. If both queries check out, the primitive variables of the current patch + ! are written to this cell. do j = 0, n do i = 0, m if (patch_icpp(patch_id)%smoothen) then @@ -751,14 +752,16 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_sweep_line !> The Taylor Green vortex is 2D decaying vortex that may be used, for example, to verify the effects of viscous attenuation. !! Geometry of the patch is well-defined when its centroid are provided. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_2D_TaylorGreen_Vortex(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -769,6 +772,7 @@ contains integer :: i, j, k !< generic loop iterators real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters real(wp) :: L0, U0 !< Taylor Green Vortex parameters + @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -782,27 +786,22 @@ contains length_x = patch_icpp(patch_id)%length_x length_y = patch_icpp(patch_id)%length_y - ! Computing the beginning and the end x- and y-coordinates - ! of the patch based on its centroid and lengths + ! Computing the beginning and the end x- and y-coordinates of the patch based on its centroid and lengths x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x y_boundary%beg = y_centroid - 0.5_wp*length_y y_boundary%end = y_centroid + 0.5_wp*length_y - ! Since the patch doesn't allow for its boundaries to be - ! smoothed out, the pseudo volume fraction is set to 1 to - ! ensure that only the current patch contributes to the fluid - ! state in the cells that this patch covers. + ! Since the patch doesn't allow for its boundaries to be smoothed out, the pseudo volume fraction is set to 1 to ensure that + ! only the current patch contributes to the fluid state in the cells that this patch covers. eta = 1._wp ! U0 is the characteristic velocity of the vortex U0 = patch_icpp(patch_id)%vel(1) ! L0 is the characteristic length of the vortex L0 = patch_icpp(patch_id)%vel(2) - ! Checking whether the patch covers a particular cell in the - ! domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, - ! the primitive variables of the current patch are assigned - ! to this cell. + ! Checking whether the patch covers a particular cell in the domain and verifying whether the current patch has the + ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to + ! this cell. do j = 0, n do i = 0, m if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. y_boundary%beg <= y_cc(j) & @@ -821,21 +820,22 @@ contains q_prim_vf(mom_idx%beg)%sf(i, j, 0) = U0*sin(x_cc(i)/L0)*cos(y_cc(j)/L0) q_prim_vf(mom_idx%end)%sf(i, j, 0) = -U0*cos(x_cc(i)/L0)*sin(y_cc(j)/L0) q_prim_vf(E_idx)%sf(i, j, & - & 0) = patch_icpp(patch_id)%pres + (cos(2*x_cc(i))/L0 + cos(2*y_cc(j))/L0)*(q_prim_vf(1)%sf(i, j, & - & 0)*U0*U0)/16 + & 0) = patch_icpp(patch_id)%pres + (cos(2*x_cc(i))/L0 + cos(2*y_cc(j))/L0)*(q_prim_vf(1)%sf(i, j, & + & 0)*U0*U0)/16 end if end do end do @:HardcodedDellacation() + end subroutine s_icpp_2D_TaylorGreen_Vortex !> @brief Initializes a 1D bubble-pulse patch with analytical primitive variable profiles. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_1d_bubble_pulse(patch_id, patch_id_fp, q_prim_vf) - ! Description: This patch assigns the primitive variables as analytical - ! functions such that the code can be verified. + + ! Description: This patch assigns the primitive variables as analytical functions such that the code can be verified. ! Patch identifier integer, intent(in) :: patch_id @@ -850,6 +850,7 @@ contains integer :: i, j, k ! Placeholders for the cell boundary values real(wp) :: pi_inf, gamma, lit_gamma + @:HardcodedDimensionsExtrusion() @:Hardcoded1DVariables() @@ -861,21 +862,17 @@ contains x_centroid = patch_icpp(patch_id)%x_centroid length_x = patch_icpp(patch_id)%length_x - ! Computing the beginning and the end x- and y-coordinates - ! of the patch based on its centroid and lengths + ! Computing the beginning and the end x- and y-coordinates of the patch based on its centroid and lengths x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x - ! Since the patch doesn't allow for its boundaries to be - ! smoothed out, the pseudo volume fraction is set to 1 to - ! ensure that only the current patch contributes to the fluid - ! state in the cells that this patch covers. + ! Since the patch doesn't allow for its boundaries to be smoothed out, the pseudo volume fraction is set to 1 to ensure that + ! only the current patch contributes to the fluid state in the cells that this patch covers. eta = 1._wp - ! Checking whether the line segment covers a particular cell in the - ! domain and verifying whether the current patch has the permission - ! to write to that cell. If both queries check out, the primitive - ! variables of the current patch are assigned to this cell. + ! Checking whether the line segment covers a particular cell in the domain and verifying whether the current patch has the + ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to + ! this cell. do i = 0, m if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, & & 0, 0))) then @@ -888,6 +885,7 @@ contains end if end do @:HardcodedDellacation() + end subroutine s_icpp_1D_bubble_pulse !> 2D modal (Fourier) patch. theta = atan2(y - y_centroid, x - x_centroid). Additive (modal_use_exp_form false): R = radius + @@ -895,6 +893,7 @@ contains !! max(R,0). If modal_clip_r_to_min, R = max(R, modal_r_min). Exponential (modal_use_exp_form true): R = radius*exp(sum); !! coefficients are relative (dimensionless). subroutine s_icpp_2d_modal(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -922,7 +921,7 @@ contains sum_series = 0._wp do nn = 1, max_2d_fourier_modes sum_series = sum_series + patch_icpp(patch_id)%fourier_cos(nn)*cos(real(nn, & - & wp)*theta) + patch_icpp(patch_id)%fourier_sin(nn)*sin(real(nn, wp)*theta) + & wp)*theta) + patch_icpp(patch_id)%fourier_sin(nn)*sin(real(nn, wp)*theta) end do if (patch_icpp(patch_id)%modal_use_exp_form) then R_boundary = patch_icpp(patch_id)%radius*exp(sum_series) @@ -942,11 +941,13 @@ contains end if end do end do + end subroutine s_icpp_2d_modal !> 3D spherical harmonic patch. Surface r = radius + sum_lm sph_har_coeff(l,m)*Y_lm(theta,phi). theta = acos(z/r), phi = !! atan2(y,x) relative to centroid. subroutine s_icpp_3d_spherical_harmonic(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1002,15 +1003,17 @@ contains end do end do end do + end subroutine s_icpp_3d_spherical_harmonic !> The spherical patch is a 3D geometry that may be used, for example, in creating a bubble or a droplet. The patch geometry is !! well-defined when its centroid and radius are provided. Please note that the spherical patch DOES allow for the smoothing of !! its boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_sphere(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1022,14 +1025,14 @@ contains ! Generic loop iterators integer :: i, j, k real(wp) :: radius + @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() - !! Variables to initialize the pressure field that corresponds to the - !! bubble-collapse test case found in Tiwari et al. (2013) + !! Variables to initialize the pressure field that corresponds to the bubble-collapse test case found in Tiwari et al. + !! (2013) - ! Transferring spherical patch's radius, centroid, smoothing patch - ! identity and smoothing coefficient information + ! Transferring spherical patch's radius, centroid, smoothing patch identity and smoothing coefficient information x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid z_centroid = patch_icpp(patch_id)%z_centroid @@ -1037,15 +1040,12 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Initializing the pseudo volume fraction value to 1. The value will - ! be modified as the patch is laid out on the grid, but only in the - ! case that smoothing of the spherical patch's boundary is enabled. + ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but + ! only in the case that smoothing of the spherical patch's boundary is enabled. eta = 1._wp - ! Checking whether the sphere covers a particular cell in the domain - ! and verifying whether the current patch has permission to write to - ! that cell. If both queries check out, the primitive variables of - ! the current patch are assigned to this cell. + ! Checking whether the sphere covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. do k = 0, p do j = 0, n do i = 0, m @@ -1058,8 +1058,8 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = tanh(smooth_coeff/min(dx, dy, & - & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) - radius) & - & )*(-0.5_wp) + 0.5_wp + & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) & + & - radius))*(-0.5_wp) + 0.5_wp end if if ((((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2 + (cart_z - z_centroid)**2 <= radius**2) & @@ -1076,16 +1076,18 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_sphere !> The cuboidal patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post-shock region, !! which is aligned with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x-, y- and z-coordinate directions are provided. Please notice that the cuboidal patch DOES NOT !! allow for the smearing of its boundaries. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_cuboid(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1094,6 +1096,7 @@ contains #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators + @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1105,8 +1108,7 @@ contains length_y = patch_icpp(patch_id)%length_y length_z = patch_icpp(patch_id)%length_z - ! Computing the beginning and the end x-, y- and z-coordinates of - ! the cuboid based on its centroid and lengths + ! Computing the beginning and the end x-, y- and z-coordinates of the cuboid based on its centroid and lengths x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x y_boundary%beg = y_centroid - 0.5_wp*length_y @@ -1114,16 +1116,13 @@ contains z_boundary%beg = z_centroid - 0.5_wp*length_z z_boundary%end = z_centroid + 0.5_wp*length_z - ! Since the cuboidal patch does not allow for its boundaries to get - ! smoothed out, the pseudo volume fraction is set to 1 to make sure - ! that only the current patch contributes to the fluid state in the - ! cells that this patch covers. + ! Since the cuboidal patch does not allow for its boundaries to get smoothed out, the pseudo volume fraction is set to 1 to + ! make sure that only the current patch contributes to the fluid state in the cells that this patch covers. eta = 1._wp - ! Checking whether the cuboid covers a particular cell in the domain - ! and verifying whether the current patch has permission to write to - ! to that cell. If both queries check out, the primitive variables - ! of the current patch are assigned to this cell. + ! Checking whether the cuboid covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to to that cell. If both queries check out, the primitive variables of the current patch are assigned to this + ! cell. do k = 0, p do j = 0, n do i = 0, m @@ -1152,16 +1151,18 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_cuboid !> The cylindrical patch is a 3D geometry that may be used, for example, in setting up a cylindrical solid boundary confinement, !! like a blood vessel. The geometry of this patch is well-defined when the centroid, the radius and the length along the !! cylinder's axis, parallel to the x-, y- or z-coordinate direction, are provided. Please note that the cylindrical patch DOES !! allow for the smoothing of its lateral boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Array of primitive variables subroutine s_icpp_cylinder(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1171,11 +1172,12 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators real(wp) :: radius + @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() - ! Transferring the cylindrical patch's centroid, length, radius, - ! smoothing patch identity and smoothing coefficient information + ! Transferring the cylindrical patch's centroid, length, radius, smoothing patch identity and smoothing coefficient + ! information x_centroid = patch_icpp(patch_id)%x_centroid y_centroid = patch_icpp(patch_id)%y_centroid z_centroid = patch_icpp(patch_id)%z_centroid @@ -1186,8 +1188,7 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Computing the beginning and the end x-, y- and z-coordinates of - ! the cylinder based on its centroid and lengths + ! Computing the beginning and the end x-, y- and z-coordinates of the cylinder based on its centroid and lengths x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x y_boundary%beg = y_centroid - 0.5_wp*length_y @@ -1195,15 +1196,13 @@ contains z_boundary%beg = z_centroid - 0.5_wp*length_z z_boundary%end = z_centroid + 0.5_wp*length_z - ! Initializing the pseudo volume fraction value to 1. The value will - ! be modified as the patch is laid out on the grid, but only in the - ! case that smearing of the cylindrical patch's boundary is enabled. + ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but + ! only in the case that smearing of the cylindrical patch's boundary is enabled. eta = 1._wp - ! Checking whether the cylinder covers a particular cell in the - ! domain and verifying whether the current patch has the permission - ! to write to that cell. If both queries check out, the primitive - ! variables of the current patch are assigned to this cell. + ! Checking whether the cylinder covers a particular cell in the domain and verifying whether the current patch has the + ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to + ! this cell. do k = 0, p do j = 0, n do i = 0, m @@ -1217,13 +1216,16 @@ contains if (patch_icpp(patch_id)%smoothen) then if (.not. f_is_default(length_x)) then eta = tanh(smooth_coeff/min(dy, & - & dz)*(sqrt((cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp + & dz)*(sqrt((cart_y - y_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) & + & + 0.5_wp else if (.not. f_is_default(length_y)) then eta = tanh(smooth_coeff/min(dx, & - & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp + & dz)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_z - z_centroid)**2) - radius))*(-0.5_wp) & + & + 0.5_wp else eta = tanh(smooth_coeff/min(dx, & - & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp + & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (cart_y - y_centroid)**2) - radius))*(-0.5_wp) & + & + 0.5_wp end if end if @@ -1249,16 +1251,18 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_cylinder !> The swept plane patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock !! region, at an angle with respect to the axes of the Cartesian coordinate system. The geometry of the patch is well-defined !! when its centroid and normal vector, aimed in the sweep direction, are provided. Note that the sweep plane patch DOES allow !! the smoothing of its boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Primitive variables + !! @param patch_id is the patch identifier + !! @param patch_id_fp Array to track patch ids + !! @param q_prim_vf Primitive variables subroutine s_icpp_sweep_plane(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1268,6 +1272,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators real(wp) :: a, b, c, d + @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1284,15 +1289,13 @@ contains c = patch_icpp(patch_id)%normal(3) d = -a*x_centroid - b*y_centroid - c*z_centroid - ! Initializing the pseudo volume fraction value to 1. The value will - ! be modified as the patch is laid out on the grid, but only in the - ! case that smearing of the sweep plane patch's boundary is enabled. + ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but + ! only in the case that smearing of the sweep plane patch's boundary is enabled. eta = 1._wp - ! Checking whether the region swept by the plane covers a particular - ! cell in the domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, the - ! primitive variables of the current patch are written to this cell. + ! Checking whether the region swept by the plane covers a particular cell in the domain and verifying whether the current + ! patch has the permission to write to that cell. If both queries check out, the primitive variables of the current patch + ! are written to this cell. do k = 0, p do j = 0, n do i = 0, m @@ -1305,7 +1308,7 @@ contains if (patch_icpp(patch_id)%smoothen) then eta = 5.e-1_wp + 5.e-1_wp*tanh(smooth_coeff/min(dx, dy, & - & dz)*(a*x_cc(i) + b*cart_y + c*cart_z + d)/sqrt(a**2 + b**2 + c**2)) + & dz)*(a*x_cc(i) + b*cart_y + c*cart_z + d)/sqrt(a**2 + b**2 + c**2)) end if if ((a*x_cc(i) + b*cart_y + c*cart_z + d >= 0._wp .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, j, & @@ -1324,6 +1327,7 @@ contains end do end do @:HardcodedDellacation() + end subroutine s_icpp_sweep_plane !> The STL patch is a 2/3D geometry that is imported from an STL file. @@ -1331,6 +1335,7 @@ contains !! @param patch_id_fp Array to track patch ids !! @param q_prim_vf Primitive variables subroutine s_icpp_model(patch_id, patch_id_fp, q_prim_vf) + integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp @@ -1340,20 +1345,20 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf ! Variables for IBM+STL - real(wp) :: normals(1:3) !< Boundary normal buffer - integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex + real(wp) :: normals(1:3) !< Boundary normal buffer + integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex real(wp), allocatable, dimension(:,:,:) :: boundary_v !< Boundary vertex buffer - real(wp) :: distance !< Levelset distance buffer - logical :: interpolate !< Logical variable to determine whether or not the model should be interpolated - integer :: i, j, k !< Generic loop iterators - type(t_bbox) :: bbox, bbox_old - type(t_model) :: model - type(ic_model_parameters) :: params - real(wp), dimension(1:3) :: point, model_center - real(wp) :: grid_mm(1:3, 1:2) - integer :: cell_num - integer :: ncells - real(wp), dimension(1:4, 1:4) :: transform, transform_n + real(wp) :: distance !< Levelset distance buffer + logical :: interpolate !< Logical variable to determine whether or not the model should be interpolated + integer :: i, j, k !< Generic loop iterators + type(t_bbox) :: bbox, bbox_old + type(t_model) :: model + type(ic_model_parameters) :: params + real(wp), dimension(1:3) :: point, model_center + real(wp) :: grid_mm(1:3, 1:2) + integer :: cell_num + integer :: ncells + real(wp), dimension(1:4, 1:4) :: transform, transform_n if (proc_rank == 0) then print *, " * Reading model: " // trim(patch_icpp(patch_id)%model_filepath) @@ -1400,8 +1405,7 @@ contains write (*, "(A, 3(2X, F20.10))") " > Cen:", (bbox%min(1:3) + bbox%max(1:3))/2._wp write (*, "(A, 3(2X, F20.10))") " > Max:", bbox%max(1:3) - ! call s_model_write("__out__.stl", model) - ! call s_model_write("__out__.obj", model) + ! call s_model_write("__out__.stl", model) call s_model_write("__out__.obj", model) grid_mm(1,:) = (/minval(x_cc) - 0.e5_wp*dx, maxval(x_cc) + 0.e5_wp*dx/) grid_mm(2,:) = (/minval(y_cc) - 0.e5_wp*dy, maxval(y_cc) + 0.e5_wp*dy/) @@ -1443,8 +1447,7 @@ contains call s_assign_patch_primitive_variables(patch_id, i, j, k, eta, q_prim_vf, patch_id_fp) - ! Note: Should probably use *eta* to compute primitive variables - ! if defining them analytically. + ! Note: Should probably use *eta* to compute primitive variables if defining them analytically. @:analytical() end do; end do; end do @@ -1454,35 +1457,42 @@ contains end if call s_model_free(model) + end subroutine s_icpp_model !> @brief Converts cylindrical (r, theta) coordinates to Cartesian (y, z) module variables. subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: cyl_y, cyl_z cart_y = cyl_y*sin(cyl_z) cart_z = cyl_y*cos(cyl_z) + end subroutine s_convert_cylindrical_to_cartesian_coord !> @brief Returns a 3D Cartesian coordinate vector from a cylindrical (x, r, theta) input vector. function f_convert_cyl_to_cart(cyl) result(cart) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(1:3), intent(in) :: cyl real(wp), dimension(1:3) :: cart cart = (/cyl(1), cyl(2)*sin(cyl(3)), cyl(2)*cos(cyl(3))/) + end function f_convert_cyl_to_cart !> @brief Computes the spherical azimuthal angle from cylindrical (x, r) coordinates. subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: cyl_x, cyl_y sph_phi = atan(cyl_y/cyl_x) + end subroutine s_convert_cylindrical_to_spherical_coord !> Archimedes spiral function @@ -1490,6 +1500,7 @@ contains !! @param offset Thickness !! @param a Starting position elemental function f_r(myth, offset, a) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: myth, offset, a real(wp) :: b @@ -1499,5 +1510,7 @@ contains b = 2._wp*a/(2._wp*pi) f_r = a + b*myth + offset + end function f_r + end module m_icpp_patches diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 269b457476..084fbeb2cf 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -4,6 +4,7 @@ !> @brief Assembles initial conditions by layering prioritized patches via constructive solid geometry module m_initial_condition + use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code use m_mpi_proxy !< Message passing interface (MPI) module proxy @@ -19,10 +20,9 @@ module m_initial_condition implicit none - ! NOTE: The abstract interface allows for the declaration of a pointer to - ! a procedure such that the choice of the model equations does not have to - ! be queried every time the patch primitive variables are to be assigned in - ! a cell in the computational domain. + ! NOTE: The abstract interface allows for the declaration of a pointer to a procedure such that the choice of the model + ! equations does not have to be queried every time the patch primitive variables are to be assigned in a cell in the + ! computational domain. type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< primitive variables type(scalar_field), allocatable, dimension(:) :: q_cons_vf !< conservative variables type(scalar_field) :: q_T_sf !< Temperature field @@ -36,12 +36,15 @@ module m_initial_condition !> @cond #endif !> @endcond + contains - !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_initial_condition_module + integer :: i, j, k, l !< generic loop iterators ! Allocating the primitive and conservative variables + allocate (q_prim_vf(1:sys_size)) allocate (q_cons_vf(1:sys_size)) @@ -63,11 +66,9 @@ contains allocate (mv%sf(0:m, 0:n, 0:p, 1:nnode, 1:nb)) end if - ! Setting default values for conservative and primitive variables so - ! that in the case that the initial condition is wrongly laid out on - ! the grid the simulation component will catch the problem on start- - ! up. The conservative variables do not need to be similarly treated - ! since they are computed directly from the primitive variables. + ! Setting default values for conservative and primitive variables so that in the case that the initial condition is wrongly + ! laid out on the grid the simulation component will catch the problem on start- up. The conservative variables do not need + ! to be similarly treated since they are computed directly from the primitive variables. do i = 1, sys_size q_cons_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) ! TODO :: remove this magic number q_prim_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) @@ -116,28 +117,29 @@ contains q_prim_vf(damage_idx)%sf = 0._wp end if - ! Initial hyper_cleaning state is always zero - ! TODO more general + ! Initial hyper_cleaning state is always zero TODO more general if (hyper_cleaning) then q_cons_vf(psi_idx)%sf = 0._wp q_prim_vf(psi_idx)%sf = 0._wp end if - ! Setting default values for patch identities bookkeeping variable. - ! This is necessary to avoid any confusion in the assessment of the - ! extent of application that the overwrite permissions give a patch - ! when it is being applied in the domain. + ! Setting default values for patch identities bookkeeping variable. This is necessary to avoid any confusion in the + ! assessment of the extent of application that the overwrite permissions give a patch when it is being applied in the + ! domain. patch_id_fp = 0 + end subroutine s_initialize_initial_condition_module !> This subroutine peruses the patches and depending on the type of geometry associated with a particular patch, it calls the !! related subroutine to setup the said geometry on the grid using the primitive variables included with the patch parameters. !! The subroutine is complete once the primitive variables are converted to conservative ones. impure subroutine s_generate_initial_condition + integer :: i - ! Converting the conservative variables to the primitive ones given - ! preexisting initial condition data files were read in on start-up + ! Converting the conservative variables to the primitive ones given preexisting initial condition data files were read in on + ! start-up + if (old_ic) then call s_convert_conservative_to_primitive_variables(q_cons_vf, q_T_sf, q_prim_vf, idwbuff) end if @@ -162,12 +164,15 @@ contains call s_initialize_mv(q_cons_vf, mv%sf) call s_initialize_pb(q_cons_vf, mv%sf, pb%sf) end if + end subroutine s_generate_initial_condition !> Deallocation procedures for the module impure subroutine s_finalize_initial_condition_module + integer :: i !< Generic loop iterator ! Dellocating the primitive and conservative variables + do i = 1, sys_size deallocate (q_prim_vf(i)%sf) deallocate (q_cons_vf(i)%sf) @@ -197,5 +202,7 @@ contains end if deallocate (bc_type) + end subroutine s_finalize_initial_condition_module + end module m_initial_condition diff --git a/src/pre_process/m_mpi_proxy.fpp b/src/pre_process/m_mpi_proxy.fpp index 3d6e1aea6f..856143dd56 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -4,20 +4,23 @@ !> @brief Broadcasts user inputs and decomposes the domain across MPI ranks for pre-processing module m_mpi_proxy + #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif use m_helper - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code use m_mpi_common implicit none + contains !> Since only processor with rank 0 is in charge of reading and checking the consistency of the user provided inputs, these are !! not available to the remaining processors. This subroutine is then in charge of broadcasting the required information. impure subroutine s_mpi_bcast_user_inputs + #ifdef MFC_MPI ! Generic loop iterator @@ -26,6 +29,7 @@ contains integer :: ierr ! Logistics + call MPI_BCAST(case_dir, len(case_dir), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) #:for VAR in ['t_step_old', 't_step_start', 'm', 'n', 'p', 'm_glb', 'n_glb', 'p_glb', & @@ -113,8 +117,8 @@ contains if (chemistry) then call MPI_BCAST(patch_icpp(i)%Y, size(patch_icpp(i)%Y), mpi_p, 0, MPI_COMM_WORLD, ierr) end if - ! Broadcast IB variables: patch_ib is indexed 1:num_patches_max, - ! not 1:num_bc_patches_max, so these must live in the num_patches_max loop. + ! Broadcast IB variables: patch_ib is indexed 1:num_patches_max, not 1:num_bc_patches_max, so these must live in the + ! num_patches_max loop. #:for VAR in ['vel', 'angular_vel', 'angles'] call MPI_BCAST(patch_ib(i)%${VAR}$, size(patch_ib(i)%${VAR}$), mpi_p, 0, MPI_COMM_WORLD, ierr) #:endfor @@ -168,5 +172,7 @@ contains end do end do #endif + end subroutine s_mpi_bcast_user_inputs + end module m_mpi_proxy diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index 059cd67b4f..c439bd0d63 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -4,6 +4,7 @@ !> @brief Perturbs initial mean flow fields with random noise, mixing-layer instabilities, or simplex noise module m_perturbation + use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code use m_mpi_proxy !< Message passing interface (MPI) module proxy @@ -15,21 +16,26 @@ module m_perturbation implicit none real(wp), allocatable, dimension(:,:,:,:) :: q_prim_temp + contains !> @brief Allocates the temporary primitive variable array used by elliptic smoothing. impure subroutine s_initialize_perturbation_module() + if (elliptic_smoothing) then allocate (q_prim_temp(0:m, 0:n, 0:p, 1:sys_size)) end if + end subroutine s_initialize_perturbation_module !> @brief Randomly perturbs partial density fields at the interface of a spherical volume fraction region. impure subroutine s_perturb_sphere(q_prim_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer :: i, j, k, l !< generic loop operators real(wp) :: perturb_alpha real(wp) :: rand_real + call random_seed() do k = 0, p @@ -39,8 +45,8 @@ contains perturb_alpha = q_prim_vf(E_idx + perturb_sph_fluid)%sf(i, j, k) - ! Perturb partial density fields to match perturbed volume fraction fields - ! IF ((perturb_alpha >= 25e-2_wp) .AND. (perturb_alpha <= 75e-2_wp)) THEN + ! Perturb partial density fields to match perturbed volume fraction fields IF ((perturb_alpha >= 25e-2_wp) .AND. + ! (perturb_alpha <= 75e-2_wp)) THEN if ((.not. f_approx_equal(perturb_alpha, 0._wp)) .and. (.not. f_approx_equal(perturb_alpha, 1._wp))) then ! Derive new partial densities do l = 1, num_fluids @@ -50,14 +56,17 @@ contains end do end do end do + end subroutine s_perturb_sphere !> @brief Adds random noise to the velocity and void fraction of the surrounding flow field. impure subroutine s_perturb_surrounding_flow(q_prim_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< generic loop iterators real(wp) :: perturb_alpha real(wp) :: rand_real + call random_seed() ! Perturb partial density or velocity of surrounding flow by some random small amount of noise @@ -75,10 +84,12 @@ contains end do end do end do + end subroutine s_perturb_surrounding_flow !> @brief Iteratively smooths all primitive variable fields using a discrete elliptic (Laplacian) filter. impure subroutine s_elliptic_smoothing(q_prim_vf, bc_type) + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type integer :: i, j, k, l, q @@ -92,7 +103,7 @@ contains do j = 0, m do i = 1, sys_size q_prim_temp(j, 0, 0, i) = (1._wp/4._wp)*(q_prim_vf(i)%sf(j + 1, 0, 0) + q_prim_vf(i)%sf(j - 1, 0, & - & 0) + 2._wp*q_prim_vf(i)%sf(j, 0, 0)) + & 0) + 2._wp*q_prim_vf(i)%sf(j, 0, 0)) end do end do else if (p == 0) then @@ -100,7 +111,8 @@ contains do j = 0, m do i = 1, sys_size q_prim_temp(j, k, 0, i) = (1._wp/8._wp)*(q_prim_vf(i)%sf(j + 1, k, 0) + q_prim_vf(i)%sf(j - 1, k, & - & 0) + q_prim_vf(i)%sf(j, k + 1, 0) + q_prim_vf(i)%sf(j, k - 1, 0) + 4._wp*q_prim_vf(i)%sf(j, k, 0)) + & 0) + q_prim_vf(i)%sf(j, k + 1, 0) + q_prim_vf(i)%sf(j, k - 1, & + & 0) + 4._wp*q_prim_vf(i)%sf(j, k, 0)) end do end do end do @@ -110,8 +122,9 @@ contains do j = 0, m do i = 1, sys_size q_prim_temp(j, k, l, i) = (1._wp/12._wp)*(q_prim_vf(i)%sf(j + 1, k, l) + q_prim_vf(i)%sf(j - 1, & - & k, l) + q_prim_vf(i)%sf(j, k + 1, l) + q_prim_vf(i)%sf(j, k - 1, l) + q_prim_vf(i)%sf(j, k, & - & l + 1) + q_prim_vf(i)%sf(j, k, l - 1) + 6._wp*q_prim_vf(i)%sf(j, k, l)) + & k, l) + q_prim_vf(i)%sf(j, k + 1, l) + q_prim_vf(i)%sf(j, k - 1, & + & l) + q_prim_vf(i)%sf(j, k, l + 1) + q_prim_vf(i)%sf(j, k, & + & l - 1) + 6._wp*q_prim_vf(i)%sf(j, k, l)) end do end do end do @@ -129,10 +142,12 @@ contains end do end do end do + end subroutine s_elliptic_smoothing !> @brief Perturbs velocity and volume fraction fields using multi-octave simplex noise. subroutine s_perturb_simplex(q_prim_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(wp) :: mag, freq, scale, vel_rsm real(wp), dimension(:,:), allocatable :: ofs @@ -205,7 +220,7 @@ contains mag = f_simplex3d(xl, yl, zl) end if q_prim_vf(contxb + i - 1)%sf(j, k, l) = q_prim_vf(contxb + i - 1)%sf(j, k, & - & l) + q_prim_vf(contxb + i - 1)%sf(j, k, l)*scale*mag + & l) + q_prim_vf(contxb + i - 1)%sf(j, k, l)*scale*mag end do end do end do @@ -213,12 +228,14 @@ contains end do deallocate (ofs) + end subroutine s_perturb_simplex !> This subroutine computes velocity perturbations for a temporal mixing layer with a hyperbolic tangent mean streamwise !! velocity profile, using an inverted version of the spectrum-based synthetic turbulence generation method proposed by Guo et !! al. (2023, JFM). subroutine s_perturb_mixlayer(q_prim_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf real(wp), dimension(mixlayer_perturb_nk) :: k, Ek real(wp), dimension(3, 3) :: Rij, Lmat @@ -227,6 +244,7 @@ contains integer :: i, j, l, r, ierr ! Initialize parameters + dk = 1._wp/mixlayer_perturb_nk ! Compute prescribed energy spectra @@ -239,8 +257,7 @@ contains ! Main loop do r = 0, n - ! Compute prescribed Reynolds stress tensor with about half - ! magnitude of its self-similar value + ! Compute prescribed Reynolds stress tensor with about half magnitude of its self-similar value Rij(:,:) = 0._wp uu0 = patch_icpp(1)%vel(1)**2._wp*(1._wp - tanh(y_cc(r)*mixlayer_vel_coef)**2._wp) Rij(1, 1) = 0.05_wp*uu0 @@ -262,8 +279,7 @@ contains ! Compute perturbation for each Fourier component do i = 1, mixlayer_perturb_nk - ! Generate random numbers for unit wavevector khat, - ! random unit vector xi, and random mode phase phi + ! Generate random numbers for unit wavevector khat, random unit vector xi, and random mode phase phi if (proc_rank == 0) then call s_generate_random_perturbation(khat, xi, phi, i, y_cc(r)) end if @@ -293,10 +309,12 @@ contains end do end do end do + end subroutine s_perturb_mixlayer !> @brief Generates deterministic pseudo-random wave vector, polarization, and phase for a perturbation mode. subroutine s_generate_random_perturbation(khat, xi, phi, ik, yloc) + integer, intent(in) :: ik real(wp), intent(in) :: yloc real(wp), dimension(3), intent(out) :: khat, xi @@ -317,10 +335,12 @@ contains xi = f_unit_vector(theta, eta) call s_prng(phi, seed) + end subroutine s_generate_random_perturbation !> @brief Generates a unit vector uniformly distributed on the sphere from two random parameters. function f_unit_vector(theta, eta) result(vec) + real(wp), intent(in) :: theta, eta real(wp) :: zeta, xi real(wp), dimension(3) :: vec @@ -330,20 +350,24 @@ contains vec(1) = sin(zeta)*cos(xi) vec(2) = sin(zeta)*sin(xi) vec(3) = cos(zeta) + end function f_unit_vector - !> This function generates a pseudo-random number between 0 and 1 based on linear congruential generator. + !> This function generates a pseudo-random number between 0 and 1 based on linear congruential generator. subroutine s_prng(var, seed) + integer, intent(inout) :: seed real(wp), intent(out) :: var integer :: i seed = mod(modmul(seed), modulus) var = seed/real(modulus, wp) + end subroutine s_prng !> @brief Computes a modular multiplication step for the linear congruential pseudo-random number generator. function modmul(a) result(val) + integer, intent(in) :: a integer :: val real(wp) :: x, y @@ -351,12 +375,16 @@ contains x = (multiplier/real(modulus, wp))*a + (increment/real(modulus, wp)) y = nint((x - floor(x))*decimal_trim)/decimal_trim val = nint(y*modulus) + end function modmul !> @brief Deallocates the temporary primitive variable array used by elliptic smoothing. impure subroutine s_finalize_perturbation_module() + if (elliptic_smoothing) then deallocate (q_prim_temp) end if + end subroutine s_finalize_perturbation_module + end module m_perturbation diff --git a/src/pre_process/m_simplex_noise.fpp b/src/pre_process/m_simplex_noise.fpp index 5b8bc72e60..487b4f5022 100644 --- a/src/pre_process/m_simplex_noise.fpp +++ b/src/pre_process/m_simplex_noise.fpp @@ -4,6 +4,7 @@ !> @brief 2D and 3D simplex noise generation for procedural initial condition perturbations module m_simplex_noise + use m_constants use m_precision_select @@ -12,37 +13,43 @@ module m_simplex_noise private; public :: f_simplex3d, f_simplex2d integer, parameter :: p_vec(0:511) = [151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, 53, 194, 233, 7, 225, 140, 36, 103, & - & 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, 252, 219, 203, 117, 35, & - & 11, 32, 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, & - & 77, 146, 158, 231, 83, 111, 229, 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, & - & 63, 161, 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, 159, 86, 164, 100, 109, & - & 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, & - & 16, 58, 17, 182, 189, 28, 42, 223, 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, & - & 9, 129, 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, 34, 242, 193, & - & 238, 210, 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, & - & 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, & - & 66, 215, 61, 156, 180, 151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, 53, 194, 233, 7, 225, 140, 36, 103, 30, 69, & - & 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, 252, 219, 203, 117, 35, 11, 32, & - & 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, & - & 158, 231, 83, 111, 229, 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, 63, 161, & - & 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, 159, 86, 164, 100, 109, 198, 173, & - & 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, 16, 58, & - & 17, 182, 189, 28, 42, 223, 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, 129, & - & 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, 34, 242, 193, 238, 210, & - & 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, 84, 204, & - & 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, 66, 215, & - & 61, 156, 180] + & 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, 120, 234, 75, 0, 26, 197, 62, 94, & + & 252, 219, 203, 117, 35, 11, 32, 57, 177, 33, 88, 237, 149, 56, 87, 174, 20, 125, 136, 171, 168, & + & 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, 231, 83, 111, 229, 122, 60, 211, & + & 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, 54, 65, 25, 63, 161, 1, 216, 80, & + & 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, 116, 188, 159, 86, 164, 100, 109, & + & 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, 38, 147, 118, 126, 255, 82, 85, 212, & + & 207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, 183, 170, 213, 119, 248, 152, 2, 44, & + & 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, 129, 22, 39, 253, 19, 98, 108, 110, 79, 113, & + & 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, 34, 242, 193, 238, 210, 144, 12, 191, & + & 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, 192, 214, 31, 181, 199, 106, 157, 184, & + & 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, 236, 205, 93, 222, 114, 67, 29, 24, 72, & + & 243, 141, 128, 195, 78, 66, 215, 61, 156, 180, 151, 160, 137, 91, 90, 15, 131, 13, 201, 95, 96, & + & 53, 194, 233, 7, 225, 140, 36, 103, 30, 69, 142, 8, 99, 37, 240, 21, 10, 23, 190, 6, 148, 247, & + & 120, 234, 75, 0, 26, 197, 62, 94, 252, 219, 203, 117, 35, 11, 32, 57, 177, 33, 88, 237, 149, & + & 56, 87, 174, 20, 125, 136, 171, 168, 68, 175, 74, 165, 71, 134, 139, 48, 27, 166, 77, 146, 158, & + & 231, 83, 111, 229, 122, 60, 211, 133, 230, 220, 105, 92, 41, 55, 46, 245, 40, 244, 102, 143, & + & 54, 65, 25, 63, 161, 1, 216, 80, 73, 209, 76, 132, 187, 208, 89, 18, 169, 200, 196, 135, 130, & + & 116, 188, 159, 86, 164, 100, 109, 198, 173, 186, 3, 64, 52, 217, 226, 250, 124, 123, 5, 202, & + & 38, 147, 118, 126, 255, 82, 85, 212, 207, 206, 59, 227, 47, 16, 58, 17, 182, 189, 28, 42, 223, & + & 183, 170, 213, 119, 248, 152, 2, 44, 154, 163, 70, 221, 153, 101, 155, 167, 43, 172, 9, 129, & + & 22, 39, 253, 19, 98, 108, 110, 79, 113, 224, 232, 178, 185, 112, 104, 218, 246, 97, 228, 251, & + & 34, 242, 193, 238, 210, 144, 12, 191, 179, 162, 241, 81, 51, 145, 235, 249, 14, 239, 107, 49, & + & 192, 214, 31, 181, 199, 106, 157, 184, 84, 204, 176, 115, 121, 50, 45, 127, 4, 150, 254, 138, & + & 236, 205, 93, 222, 114, 67, 29, 24, 72, 243, 141, 128, 195, 78, 66, 215, 61, 156, 180] real(wp), parameter :: grad3(12, 3) = reshape([1._wp, 1._wp, 0._wp, -1._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, -1._wp, & - & -1._wp, 0._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, 1._wp, 1._wp, 0._wp, -1._wp, -1._wp, 0._wp, -1._wp, 0._wp, 1._wp, & - & 1._wp, 0._wp, -1._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, -1._wp, -1._wp], shape=[12, 3]) + & -1._wp, 0._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, 1._wp, 1._wp, 0._wp, -1._wp, -1._wp, 0._wp, -1._wp, 0._wp, 1._wp, & + & 1._wp, 0._wp, -1._wp, 1._wp, 0._wp, 1._wp, -1._wp, 0._wp, -1._wp, -1._wp], shape=[12, 3]) real(wp), parameter :: grad2(10, 2) = reshape([1._wp, 1._wp, -1._wp, 1._wp, 1._wp, -1._wp, -1._wp, -1._wp, 1._wp, 0._wp, & - & -1._wp, 0._wp, 0._wp, 1._wp, 0._wp, -1._wp, 1._wp, 1._wp, -1._wp, 1._wp], shape=[10, 2]) + & -1._wp, 0._wp, 0._wp, 1._wp, 0._wp, -1._wp, 1._wp, 1._wp, -1._wp, 1._wp], shape=[10, 2]) + contains !> @brief Evaluates 3D simplex noise at the given coordinates and returns a value in [-1, 1]. function f_simplex3d(xin, yin, zin) result(n) + real(wp), intent(in) :: xin, yin, zin real(wp) :: n real(wp) :: n0, n1, n2, n3 @@ -138,10 +145,12 @@ contains end if n = 32._wp*(n0 + n1 + n2 + n3) + end function f_simplex3d !> @brief Evaluates 2D simplex noise at the given coordinates and returns a value in [-1, 1]. function f_simplex2d(xin, yin) result(n) + real(wp), intent(in) :: xin, yin real(wp) :: n real(wp), parameter :: F2 = 0.5_wp*(sqrt(3._wp) - 1._wp) @@ -203,13 +212,18 @@ contains end if n = 70._wp*(n0 + n1 + n2) + end function f_simplex2d !> @brief Computes the dot product of a 2D gradient vector with the given offset coordinates. function dot2(g, x, y) result(dot) + integer, intent(in) :: g real(wp), intent(in) :: x, y real(wp) :: dot + dot = grad2(g + 1, 1)*x + grad2(g + 1, 2)*y + end function dot2 + end module m_simplex_noise diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index f745a35552..c124fd492d 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -6,19 +6,20 @@ !> @brief Reads and validates user inputs, loads existing grid/IC data, and initializes pre-process modules module m_start_up - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Global parameters for the code + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_mpi_common use m_variables_conversion !< Subroutines to change the state variables from one form to another - use m_grid !< Procedures to generate (non-)uniform grids - use m_initial_condition !< Procedures to generate initial condition - use m_data_output !< Procedures to write the grid data and the conservative variables to files - use m_compile_specific !< Compile-specific procedures + use m_grid !< Procedures to generate (non-)uniform grids + use m_initial_condition !< Procedures to generate initial condition + use m_data_output !< Procedures to write the grid data and the conservative variables to files + use m_compile_specific !< Compile-specific procedures use m_icpp_patches use m_assign_variables - use m_phase_change !< Phase-change module - use m_helper_basic !< Functions to compare floating point numbers + use m_phase_change !< Phase-change module + use m_helper_basic !< Functions to compare floating point numbers use m_helper #ifdef MFC_MPI @@ -44,13 +45,17 @@ module m_start_up !> @brief Abstract interface for reading grid data files in serial or parallel. impure subroutine s_read_abstract_grid_data_files + end subroutine s_read_abstract_grid_data_files + !> @brief Abstract interface for reading initial condition data files in serial or parallel. !! @param q_cons_vf Conservative variables impure subroutine s_read_abstract_ic_data_files(q_cons_vf_in) + import :: scalar_field, integer_field, sys_size, pres_field type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in + end subroutine s_read_abstract_ic_data_files end interface @@ -60,20 +65,23 @@ module m_start_up character(LEN=path_len + 2*name_len), private :: t_step_dir procedure(s_read_abstract_grid_data_files), pointer :: s_read_grid_data_files => null() procedure(s_read_abstract_ic_data_files), pointer :: s_read_ic_data_files => null() + contains !> Reads the configuration file pre_process.inp, in order to populate the parameters in module m_global_parameters.f90 with the !! user provided inputs impure subroutine s_read_input_file + character(LEN=name_len) :: file_loc !< Generic string used to store the address of a particular file !> Generic logical used for the purpose of asserting whether a file is or is not present in the designated location logical :: file_check integer :: iostatus - !! Integer to check iostat of file read + !! Integer to check iostat of file read character(len=1000) :: line ! Namelist for all of the parameters to be inputted by the user + namelist /user_inputs/ case_dir, old_grid, old_ic, t_step_old, t_step_start, m, n, p, x_domain, y_domain, z_domain, & & stretch_x, stretch_y, stretch_z, a_x, a_y, a_z, x_a, y_a, z_a, x_b, y_b, z_b, model_eqns, num_fluids, mpp_lim, & & weno_order, bc_x, bc_y, bc_z, num_patches, hypoelasticity, mhd, patch_icpp, fluid_pp, bub_pp, precision, & @@ -90,8 +98,7 @@ contains file_loc = 'pre_process.inp' inquire (FILE=trim(file_loc), EXIST=file_check) - ! Checking whether the input file is there. If it is, the input file - ! is read. If not, the program is terminated. + ! Checking whether the input file is there. If it is, the input file is read. If not, the program is terminated. if (file_check) then open (1, FILE=trim(file_loc), form='formatted', STATUS='old', ACTION='read') read (1, NML=user_inputs, iostat=iostatus) @@ -120,14 +127,17 @@ contains else call s_mpi_abort('File pre_process.inp is missing. Exiting.') end if + end subroutine s_read_input_file !> Checking that the user inputs make sense, i.e. that the individual choices are compatible with the code's options and that !! the combination of these choices results into a valid configuration for the pre-process impure subroutine s_check_input_file + character(LEN=len_trim(case_dir)) :: file_loc !< Generic string used to store the address of a particular file logical :: dir_check !< Logical variable used to test the existence of folders ! Checking the existence of the case folder + case_dir = adjustl(case_dir) file_loc = trim(case_dir) // '/.' @@ -147,22 +157,24 @@ contains call s_check_patches() if (ib) call s_check_ib_patches() + end subroutine s_check_input_file !> The goal of this subroutine is to read in any preexisting grid data as well as based on the imported grid, complete the !! necessary global computational domain parameters. impure subroutine s_read_serial_grid_data_files + ! Generic string used to store the address of a particular file character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc ! Logical variable used to test the existence of folders logical :: dir_check - ! Generic logical used for the purpose of asserting whether a file - ! is or is not present in the designated location + ! Generic logical used for the purpose of asserting whether a file is or is not present in the designated location logical :: file_check ! Setting address of the local processor rank and time-step directory + write (proc_rank_dir, '(A,I0)') '/p_all/p', proc_rank proc_rank_dir = trim(case_dir) // trim(proc_rank_dir) @@ -259,21 +271,21 @@ contains end if end if - ! If only the preexisting grid data files are read in and there will - ! not be any preexisting initial condition data files imported, then - ! the directory associated with the rank of the local processor may - ! be cleaned to make room for the new pre-process data. In addition, - ! the time-step directory that will contain the new grid and initial - ! condition data are also generated. + ! If only the preexisting grid data files are read in and there will not be any preexisting initial condition data files + ! imported, then the directory associated with the rank of the local processor may be cleaned to make room for the new + ! pre-process data. In addition, the time-step directory that will contain the new grid and initial condition data are also + ! generated. if (old_ic .neqv. .true.) then call s_delete_directory(trim(proc_rank_dir)) call s_create_directory(trim(proc_rank_dir) // '/0') end if + end subroutine s_read_serial_grid_data_files !> Cell-boundary data are checked for consistency by looking at the (non-)uniform cell-width distributions for all the active !! coordinate directions and making sure that all of the cell-widths are positively valued impure subroutine s_check_grid_data_files + ! Cell-boundary Data Consistency Check in x-direction if (any(x_cb(0:m) - x_cb(-1:m - 1) <= 0._wp)) then @@ -295,12 +307,14 @@ contains end if end if end if + end subroutine s_check_grid_data_files !> The goal of this subroutine is to read in any preexisting initial condition data files so that they may be used by the !! pre-process as a starting point in the creation of an all new initial condition. - !! @param q_cons_vf_in Conservative variables + !! @param q_cons_vf_in Conservative variables impure subroutine s_read_serial_ic_data_files(q_cons_vf_in) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc ! Generic string used to store the address of a particular file @@ -311,9 +325,9 @@ contains logical :: file_check integer :: i, r !< Generic loop iterator ! Reading the Conservative Variables Data Files + do i = 1, sys_size - ! Checking whether data file associated with variable position - ! of the currently manipulated conservative variable exists + ! Checking whether data file associated with variable position of the currently manipulated conservative variable exists write (file_num, '(I0)') i file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) @@ -332,8 +346,8 @@ contains if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - ! Checking whether data file associated with variable position - ! of the currently manipulated bubble variable exists + ! Checking whether data file associated with variable position of the currently manipulated bubble variable + ! exists write (file_num, '(I0)') sys_size + r + (i - 1)*nnode file_loc = trim(t_step_dir) // '/pb' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) @@ -351,8 +365,8 @@ contains do i = 1, nb do r = 1, nnode - ! Checking whether data file associated with variable position - ! of the currently manipulated bubble variable exists + ! Checking whether data file associated with variable position of the currently manipulated bubble variable + ! exists write (file_num, '(I0)') sys_size + r + (i - 1)*nnode file_loc = trim(t_step_dir) // '/mv' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) @@ -369,18 +383,18 @@ contains end do end if - ! Since the preexisting grid and initial condition data files have - ! been read in, the directory associated with the rank of the local - ! process may be cleaned out to make room for new pre-process data. - ! In addition, the time-step folder that will contain the new grid - ! and initial condition data are also generated. + ! Since the preexisting grid and initial condition data files have been read in, the directory associated with the rank of + ! the local process may be cleaned out to make room for new pre-process data. In addition, the time-step folder that will + ! contain the new grid and initial condition data are also generated. call s_delete_directory(trim(proc_rank_dir)) call s_create_directory(trim(proc_rank_dir) // '/0') + end subroutine s_read_serial_ic_data_files !> Cell-boundary data are checked for consistency by looking at the (non-)uniform cell-width distributions for all the active !! coordinate directions and making sure that all of the cell-widths are positively valued impure subroutine s_read_parallel_grid_data_files + #ifdef MFC_MPI real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb @@ -471,12 +485,14 @@ contains deallocate (x_cb_glb, y_cb_glb, z_cb_glb) #endif + end subroutine s_read_parallel_grid_data_files !> The goal of this subroutine is to read in any preexisting initial condition data files so that they may be used by the !! pre-process as a starting point in the creation of an all new initial condition. - !! @param q_cons_vf_in Conservative variables + !! @param q_cons_vf_in Conservative variables impure subroutine s_read_parallel_ic_data_files(q_cons_vf_in) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in #ifdef MFC_MPI @@ -493,6 +509,7 @@ contains integer :: i ! Open the file to read + if (cfl_adap_dt) then write (file_loc, '(I0,A)') n_start, '.dat' else @@ -550,12 +567,13 @@ contains call s_mpi_barrier() #endif + end subroutine s_read_parallel_ic_data_files !> @brief Initializes all pre-process modules, allocates data structures, and sets I/O procedure pointers. impure subroutine s_initialize_modules - ! Computation of parameters, allocation procedures, and/or any other tasks - ! needed to properly setup the modules + + ! Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the modules call s_initialize_global_parameters_module() if (bubbles_euler .or. bubbles_lagrange) then call s_initialize_bubbles_model() @@ -570,8 +588,7 @@ contains call s_initialize_boundary_common_module() if (relax) call s_initialize_phasechange_module() - ! Create the D directory if it doesn't exit, to store - ! the serial data files + ! Create the D directory if it doesn't exit, to store the serial data files call s_create_directory('D') ! Associate pointers for serial or parallel I/O @@ -586,10 +603,12 @@ contains s_read_ic_data_files => s_read_parallel_ic_data_files s_write_data_files => s_write_parallel_data_files end if + end subroutine s_initialize_modules !> @brief Reads an existing grid from data files or generates a new grid from user inputs. impure subroutine s_read_grid() + if (old_grid) then call s_read_grid_data_files() call s_check_grid_data_files() @@ -603,24 +622,24 @@ contains call s_check_grid_data_files() end if end if + end subroutine s_read_grid !> @brief Generates or reads the initial condition, applies relaxation if needed, and writes output data files. impure subroutine s_apply_initial_condition(start, finish) + real(wp), intent(inout) :: start, finish integer :: j, k, l real(wp) :: r2 - ! Setting up the grid and the initial condition. If the grid is read in from - ! preexisting grid data files, it is checked for consistency. If the grid is - ! not read in, it is generated from scratch according to the inputs provided - ! by the user. The initial condition may also be read in. It in turn is not - ! checked for consistency since it WILL further be edited by the pre-process - ! and also because it may be incomplete at the time it is read in. Finally, - ! when the grid and initial condition are completely setup, they are written - ! to their respective data files. + ! Setting up the grid and the initial condition. If the grid is read in from preexisting grid data files, it is checked for + ! consistency. If the grid is not read in, it is generated from scratch according to the inputs provided by the user. The + ! initial condition may also be read in. It in turn is not checked for consistency since it WILL further be edited by the + ! pre-process and also because it may be incomplete at the time it is read in. Finally, when the grid and initial condition + ! are completely setup, they are written to their respective data files. ! Setting up grid and initial condition + call cpu_time(start) if (old_ic) call s_read_ic_data_files(q_cons_vf) @@ -654,10 +673,12 @@ contains call s_write_data_files(q_cons_vf, q_prim_vf, bc_type) call cpu_time(finish) + end subroutine s_apply_initial_condition !> @brief Gathers processor timing data and writes elapsed wall-clock time to a summary file. impure subroutine s_save_data(proc_time, time_avg, time_final, file_exists) + real(wp), dimension(:), intent(inout) :: proc_time real(wp), intent(inout) :: time_avg, time_final logical, intent(inout) :: file_exists @@ -688,18 +709,19 @@ contains close (1) end if end if + end subroutine s_save_data !> @brief Initializes MPI, reads and validates user inputs on rank 0, and decomposes the computational domain. impure subroutine s_initialize_mpi_domain + ! Initialization of the MPI environment call s_mpi_initialize() - ! Rank 0 processor assigns default values to user inputs prior to reading - ! those in from the input file. Next, the user inputs are read in and their - ! consistency is checked. The detection of any inconsistencies automatically - ! leads to the termination of the pre-process. + ! Rank 0 processor assigns default values to user inputs prior to reading those in from the input file. Next, the user + ! inputs are read in and their consistency is checked. The detection of any inconsistencies automatically leads to the + ! termination of the pre-process. if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() @@ -709,16 +731,17 @@ contains print '(" Pre-processing a ", I0, "x", I0, "x", I0, " case on ", I0, " rank(s)")', m, n, p, num_procs end if - ! Broadcasting the user inputs to all of the processors and performing the - ! parallel computational domain decomposition. Neither procedure has to be - ! carried out if pre-process is in fact not truly executed in parallel. + ! Broadcasting the user inputs to all of the processors and performing the parallel computational domain decomposition. + ! Neither procedure has to be carried out if pre-process is in fact not truly executed in parallel. call s_mpi_bcast_user_inputs() call s_initialize_parallel_io() call s_mpi_decompose_computational_domain() + end subroutine s_initialize_mpi_domain !> @brief Finalizes all pre-process modules, deallocates resources, and shuts down MPI. impure subroutine s_finalize_modules + ! Disassociate pointers for serial and parallel I/O s_generate_grid => null() s_read_grid_data_files => null() @@ -738,5 +761,7 @@ contains call s_finalize_initial_condition_module() ! Finalization of the MPI environment call s_mpi_finalize() + end subroutine s_finalize_modules + end module m_start_up diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index 77c6eb59de..43e5b083c0 100644 --- a/src/pre_process/p_main.f90 +++ b/src/pre_process/p_main.f90 @@ -2,8 +2,9 @@ !! @file !! @brief Contains program p_main -!> @brief This program takes care of setting up the initial condition and grid data for the multicomponent flow code. +!> @brief This program takes care of setting up the initial condition and grid data for the multicomponent flow code. program p_main + use m_global_parameters !< Global parameters for the code use m_start_up diff --git a/src/simulation/include/inline_riemann.fpp b/src/simulation/include/inline_riemann.fpp index ede9e7b8d3..aae4015292 100644 --- a/src/simulation/include/inline_riemann.fpp +++ b/src/simulation/include/inline_riemann.fpp @@ -51,7 +51,7 @@ ! Case when T_L and T_R are very close Cp_avg = sum(Yi_avg(:)*(0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights_nonparameter(:)) Cv_avg = sum(Yi_avg(:)*((0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights_nonparameter(:) & - & - gas_constant/molecular_weights_nonparameter(:))) + & - gas_constant/molecular_weights_nonparameter(:))) else ! Normal calculation when T_L and T_R are sufficiently different Cp_avg = sum(Yi_avg(:)*(h_iR(:) - h_iL(:))/(T_R - T_L)) @@ -60,14 +60,14 @@ gamma_avg = Cp_avg/Cv_avg Phi_avg(:) = (gamma_avg - 1._wp)*(vel_avg_rms/2.0_wp - h_avg_2(:)) & - & + gamma_avg*gas_constant/molecular_weights_nonparameter(:)*T_avg + & + gamma_avg*gas_constant/molecular_weights_nonparameter(:)*T_avg c_sum_Yi_Phi = sum(Yi_avg(:)*Phi_avg(:)) #:else if (abs(T_L - T_R) < eps) then ! Case when T_L and T_R are very close Cp_avg = sum(Yi_avg(:)*(0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights(:)) Cv_avg = sum(Yi_avg(:)*((0.5_wp*Cp_iL(:) + 0.5_wp*Cp_iR(:))*gas_constant/molecular_weights(:) & - & - gas_constant/molecular_weights(:))) + & - gas_constant/molecular_weights(:))) else ! Normal calculation when T_L and T_R are sufficiently different Cp_avg = sum(Yi_avg(:)*(h_iR(:) - h_iL(:))/(T_R - T_L)) @@ -105,7 +105,7 @@ if (low_Mach == 1) then pcorr = rho_L*rho_R*(s_L - vel_L(dir_idx(1)))*(s_R - vel_R(dir_idx(1)))*(vel_R(dir_idx(1)) - vel_L(dir_idx(1))) & - & /(rho_R*(s_R - vel_R(dir_idx(1))) - rho_L*(s_L - vel_L(dir_idx(1))))*(zcoef - 1._wp) + & /(rho_R*(s_R - vel_R(dir_idx(1))) - rho_L*(s_L - vel_L(dir_idx(1))))*(zcoef - 1._wp) else if (low_Mach == 2) then vel_L_tmp = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + zcoef*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) vel_R_tmp = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + zcoef*(vel_R(dir_idx(1)) - vel_L(dir_idx(1)))) diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 438d21678c..6da3831291 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -6,12 +6,13 @@ !> @brief Applies acoustic pressure source terms including focused, planar, and broadband transducers module m_acoustic_src - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_bubbles !< Bubble dynamic routines + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_bubbles !< Bubble dynamic routines use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers - use m_constants !< Definitions of the constants + use m_helper_basic !< Functions to compare floating point numbers + use m_constants !< Definitions of the constants implicit none private; public :: s_initialize_acoustic_src, s_precalculate_acoustic_spatial_sources, s_acoustic_src_calculations @@ -53,18 +54,21 @@ module m_acoustic_src type(source_spatial_type), dimension(:), allocatable :: source_spatials !< Data of non-zero source grid points for each source $:GPU_DECLARE(create='[source_spatials]') + contains !> This subroutine initializes the acoustic source module impure subroutine s_initialize_acoustic_src + integer :: i, j !< generic loop variables + @:ALLOCATE(loc_acoustic(1:3, 1:num_source), mag(1:num_source), dipole(1:num_source), support(1:num_source), & - & length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), & - & gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), aperture(1:num_source), & - & npulse(1:num_source), pulse(1:num_source), dir(1:num_source), delay(1:num_source), & - & element_polygon_ratio(1:num_source), rotate_angle(1:num_source), element_spacing_angle(1:num_source), & - & num_elements(1:num_source), element_on(1:num_source), bb_num_freq(1:num_source), bb_bandwidth(1:num_source), & - & bb_lowest_freq(1:num_source)) + & length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), & + & gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), & + & aperture(1:num_source), npulse(1:num_source), pulse(1:num_source), dir(1:num_source), delay(1:num_source), & + & element_polygon_ratio(1:num_source), rotate_angle(1:num_source), element_spacing_angle(1:num_source), & + & num_elements(1:num_source), element_on(1:num_source), bb_num_freq(1:num_source), bb_bandwidth(1:num_source), & + & bb_lowest_freq(1:num_source)) do i = 1, num_source do j = 1, 3 @@ -108,12 +112,13 @@ contains end if end do $:GPU_UPDATE(device='[loc_acoustic, mag, dipole, support, length, height, wavelength, frequency, gauss_sigma_dist, & - & gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, element_polygon_ratio, rotate_angle, & - & element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, bb_lowest_freq]') + & gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, element_polygon_ratio, rotate_angle, & + & element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, bb_lowest_freq]') @:ALLOCATE(mass_src(0:m, 0:n, 0:p)) @:ALLOCATE(mom_src(1:num_vels, 0:m, 0:n, 0:p)) @:ALLOCATE(E_src(0:m, 0:n, 0:p)) + end subroutine s_initialize_acoustic_src !> This subroutine updates the rhs by computing the mass, mom, energy sources @@ -121,6 +126,7 @@ contains !! @param q_prim_vf Primitive variables !! @param rhs_vf rhs variables impure subroutine s_acoustic_src_calculations(q_cons_vf, q_prim_vf, rhs_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Conservative variables type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive variables type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf @@ -202,8 +208,8 @@ contains deallocate (phi_rn) $:GPU_PARALLEL_LOOP(private='[myalpha, myalpha_rho, myRho, B_tait, c, small_gamma, frequency_local, & - & gauss_sigma_time_local, mass_src_diff, mom_src_diff, source_temporal, j, k, l, q]', & - & copyin = '[sum_BB, freq_conv_flag, gauss_conv_flag, sim_time]') + & gauss_sigma_time_local, mass_src_diff, mom_src_diff, source_temporal, j, k, l, q]', & + & copyin = '[sum_BB, freq_conv_flag, gauss_conv_flag, sim_time]') do i = 1, num_points j = source_spatials(ai)%coord(1, i) k = source_spatials(ai)%coord(2, i) @@ -253,7 +259,7 @@ contains ! Update momentum source term call s_source_temporal(sim_time, c, ai, mom_label, frequency_local, gauss_sigma_time_local, source_temporal, & - & sum_BB) + & sum_BB) mom_src_diff = source_temporal*source_spatials(ai)%val(i) if (dipole(ai)) then ! Double amplitude & No momentum source term (only works for Planar) @@ -290,7 +296,7 @@ contains ! Mass source term must be calculated differently using a correction term for spherical and cylindrical ! support call s_source_temporal(sim_time, c, ai, mass_label, frequency_local, gauss_sigma_time_local, & - & source_temporal, sum_BB) + & source_temporal, sum_BB) mass_src_diff = source_temporal*source_spatials(ai)%val(i) end if mass_src(j, k, l) = mass_src(j, k, l) + mass_src_diff @@ -322,6 +328,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_acoustic_src_calculations !> This subroutine gives the temporally varying amplitude of the pulse @@ -334,6 +341,7 @@ contains !! @param source Source term amplitude !! @param sum_bb Sum of basis functions elemental subroutine s_source_temporal(sim_time, c, ai, term_index, frequency_local, gauss_sigma_time_local, source, sum_BB) + $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: ai, term_index real(wp), intent(in) :: sim_time, c, sum_BB @@ -369,7 +377,7 @@ contains if (term_index == mass_label) then source = source/c - foc_length_factor*mag(ai)*sqrt(pi/2)*gauss_sigma_time_local*(erf((sim_time - delay(ai)) & - & /(sqrt(2._wp)*gauss_sigma_time_local)) + 1) + & /(sqrt(2._wp)*gauss_sigma_time_local)) + 1) end if else if (pulse(ai) == 3) then ! Square wave if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return @@ -385,10 +393,12 @@ contains else if (pulse(ai) == 4) then ! Broadband wave source = sum_BB end if + end subroutine s_source_temporal !> This subroutine identifies and precalculates the non-zero acoustic spatial sources before time-stepping impure subroutine s_precalculate_acoustic_spatial_sources + integer :: j, k, l, ai integer :: count integer :: dim @@ -468,9 +478,10 @@ contains #ifdef MFC_DEBUG do ai = 1, num_source write (*, '(A,I2,A,I8,A)') 'Acoustic source ', ai, ' has ', source_spatials_num_points(ai), & - & ' grid points with non-zero source term' + & ' grid points with non-zero source term' end do #endif + end subroutine s_precalculate_acoustic_spatial_sources !> This subroutine gives the spatial support of the acoustic source @@ -483,12 +494,14 @@ contains !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial(j, k, l, loc, ai, source, angle, xyz_to_r_ratios) + integer, intent(in) :: j, k, l, ai real(wp), dimension(3), intent(in) :: loc real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) real(wp) :: sig, r(3) ! Calculate sig spatial support width + if (n == 0) then sig = dx(j) else if (p == 0) then @@ -510,6 +523,7 @@ contains else if (any(support(ai) == (/9, 10, 11/))) then call s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios) end if + end subroutine s_source_spatial !> This subroutine calculates the spatial support for planar acoustic sources in 1D, 2D, and 3D @@ -518,6 +532,7 @@ contains !! @param r Displacement from source to current point !! @param source Source term amplitude subroutine s_source_spatial_planar(ai, sig, r, source) + integer, intent(in) :: ai real(wp), intent(in) :: sig, r(3) real(wp), intent(out) :: source @@ -537,6 +552,7 @@ contains end if end if end if + end subroutine s_source_spatial_planar !> This subroutine calculates the spatial support for a single transducer in 2D, 2D axisymmetric, and 3D @@ -547,6 +563,7 @@ contains !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial_transducer(ai, sig, r, source, angle, xyz_to_r_ratios) + integer, intent(in) :: ai real(wp), intent(in) :: sig, r(3) real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) @@ -579,6 +596,7 @@ contains xyz_to_r_ratios(3) = -r(3)/norm end if end if + end subroutine s_source_spatial_transducer !> This subroutine calculates the spatial support for multiple transducers in 2D, 2D axisymmetric, and 3D @@ -589,6 +607,7 @@ contains !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) subroutine s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios) + integer, intent(in) :: ai real(wp), intent(in) :: sig, r(3) real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) @@ -640,8 +659,8 @@ contains y2 = half_apert*cos(angle_elem) z2 = half_apert*sin(angle_elem) - ! Construct a plane normal to the line from the focal point to the elem center, - ! Point 3 is the intercept of the plane and the line from the focal point to the current location + ! Construct a plane normal to the line from the focal point to the elem center, Point 3 is the intercept of the + ! plane and the line from the focal point to the current location C = f**2._wp/((r(1) - f)*(x2 - f) + r(2)*y2 + r(3)*z2) ! Constant for intermediate step x3 = C*(r(1) - f) + f y3 = C*r(2) @@ -659,6 +678,7 @@ contains end if end do end if + end subroutine s_source_spatial_transducer_array !> This function performs wavelength to frequency conversion @@ -667,6 +687,7 @@ contains !! @param c Speed of sound !! @return frequency_local Converted frequency elemental function f_frequency_local(freq_conv_flag, ai, c) + $:GPU_ROUTINE(parallelism='[seq]') logical, intent(in) :: freq_conv_flag integer, intent(in) :: ai @@ -678,6 +699,7 @@ contains else f_frequency_local = frequency(ai) end if + end function f_frequency_local !> This function performs Gaussian sigma dist to time conversion @@ -686,6 +708,7 @@ contains !! @param ai Acoustic source index !! @return gauss_sigma_time_local Converted Gaussian sigma time function f_gauss_sigma_time_local(gauss_conv_flag, ai, c) + $:GPU_ROUTINE(parallelism='[seq]') logical, intent(in) :: gauss_conv_flag integer, intent(in) :: ai @@ -697,5 +720,7 @@ contains else f_gauss_sigma_time_local = gauss_sigma_time(ai) end if + end function f_gauss_sigma_time_local + end module m_acoustic_src diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index 67a4dc477c..1950db63b1 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -6,7 +6,8 @@ !> @brief Computes gravitational and user-defined body force source terms for the momentum equations module m_body_forces - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_variables_conversion use m_nvtx @@ -20,10 +21,12 @@ module m_body_forces real(wp), allocatable, dimension(:,:,:) :: rhoM $:GPU_DECLARE(create='[rhoM]') + contains !> This subroutine initializes the module global array of mixture densities in each grid cell impure subroutine s_initialize_body_forces_module + ! Simulation is at least 2D if (n > 0) then ! Simulation is 3D @@ -37,26 +40,32 @@ contains else @:ALLOCATE(rhoM(-buff_size:buff_size + m, 0:0, 0:0)) end if + end subroutine s_initialize_body_forces_module !> This subroutine computes the acceleration at time t subroutine s_compute_acceleration(t) + real(wp), intent(in) :: t #:for DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + if (bf_${XYZ}$) then accel_bf(${DIR}$) = g_${XYZ}$ + k_${XYZ}$*sin(w_${XYZ}$*t - p_${XYZ}$) end if #:endfor $:GPU_UPDATE(device='[accel_bf]') + end subroutine s_compute_acceleration !> This subroutine calculates the mixture density at each cell center !! @param q_cons_vf Conservative variables subroutine s_compute_mixture_density(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf integer :: i, j, k, l !< standard iterators + $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n @@ -69,6 +78,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_compute_mixture_density !> This subroutine calculates the source term due to body forces so the system can be advanced in time @@ -76,10 +86,12 @@ contains !! @param q_prim_vf Primitive variables !! @param rhs_vf Right-hand side accumulator subroutine s_compute_body_forces_rhs(q_prim_vf, q_cons_vf, rhs_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf integer :: i, j, k, l !< Loop variables + call s_compute_acceleration(mytime) call s_compute_mixture_density(q_cons_vf) @@ -136,10 +148,14 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_compute_body_forces_rhs !> @brief Deallocates module variables used for body force computations. impure subroutine s_finalize_body_forces_module + @:DEALLOCATE(rhoM) + end subroutine s_finalize_body_forces_module + end module m_body_forces diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 998c172496..b38dbec1b8 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -7,17 +7,19 @@ !> @brief Shared bubble-dynamics procedures (radial acceleration, wall pressure, sound speed) for ensemble- and volume-averaged !! models module m_bubbles - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers implicit none real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) real(wp) :: k_mw !< Bubble wall properties (Ando 2010) real(wp) :: rho_mw !< Bubble wall properties (Ando 2010) $:GPU_DECLARE(create='[chi_vw, k_mw, rho_mw]') + contains !> Function that computes the bubble radial acceleration based on bubble models @@ -35,6 +37,7 @@ contains !! @param f_divu Divergence of velocity !! @param fCson Speed of sound from fP (EL) elemental function f_rddot(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf real(wp), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu @@ -69,6 +72,7 @@ contains ! Default: No bubble dynamics f_rddot = 0._wp end if + end function f_rddot !> Function that computes that bubble wall pressure for Gilmore bubbles @@ -77,6 +81,7 @@ contains !! @param fV Current bubble velocity !! @param fpb Internal bubble pressure elemental function f_cpbw(fR0, fR, fV, fpb) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fR0, fR, fV, fpb real(wp) :: f_cpbw @@ -86,6 +91,7 @@ contains else f_cpbw = fpb - 1._wp - 4._wp*Re_inv*fV/fR - 2._wp/(fR*Web) end if + end function f_cpbw !> Function that computes the bubble enthalpy @@ -94,6 +100,7 @@ contains !! @param fntait Tait EOS parameter !! @param fBtait Tait EOS parameter elemental function f_H(fCpbw, fCpinf, fntait, fBtait) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCpbw, fCpinf, fntait, fBtait real(wp) :: tmp1, tmp2, tmp3 @@ -104,14 +111,16 @@ contains tmp3 = (fCpinf/(1._wp + fBtait) + 1._wp)**tmp1 f_H = (tmp2 - tmp3)*fntait*(1._wp + fBtait)/(fntait - 1._wp) + end function f_H !> Function that computes the sound speed for the bubble - !! @param fCpinf Driving bubble pressure - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param fH Bubble enthalpy + !! @param fCpinf Driving bubble pressure + !! @param fntait Tait EOS parameter + !! @param fBtait Tait EOS parameter + !! @param fH Bubble enthalpy elemental function f_cgas(fCpinf, fntait, fBtait, fH) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCpinf, fntait, fBtait, fH real(wp) :: tmp @@ -122,6 +131,7 @@ contains tmp = fntait*(1._wp + fBtait)*tmp f_cgas = sqrt(tmp + (fntait - 1._wp)*fH) + end function f_cgas !> Function that computes the time derivative of the driving pressure @@ -133,13 +143,13 @@ contains !! @param advsrc Advection equation source term !! @param divu Divergence of velocity elemental function f_cpinfdot(fRho, fP, falf, fntait, fBtait, advsrc, divu) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fRho, fP, falf, fntait, fBtait, advsrc, divu real(wp) :: c2_liquid real(wp) :: f_cpinfdot - ! get sound speed squared for liquid (only needed for pbdot) - ! c_l^2 = gam (p+B) / (rho*(1-alf)) + ! get sound speed squared for liquid (only needed for pbdot) c_l^2 = gam (p+B) / (rho*(1-alf)) if (mpp_lim) then c2_liquid = fntait*(fP + fBtait)/fRho else @@ -148,6 +158,7 @@ contains ! \dot{Cp_inf} = rho sound^2 (alf_src - divu) f_cpinfdot = fRho*c2_liquid*(advsrc - divu) + end function f_cpinfdot !> Function that computes the time derivative of the enthalpy @@ -161,6 +172,7 @@ contains !! @param fR0 Equilibrium bubble radius !! @param fpbdot Time derivative of the internal bubble pressure elemental function f_Hdot(fCpbw, fCpinf, fCpinf_dot, fntait, fBtait, fR, fV, fR0, fpbdot) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCpbw, fCpinf, fCpinf_dot, fntait, fBtait real(wp), intent(in) :: fR, fV, fR0, fpbdot @@ -176,14 +188,14 @@ contains tmp2 = (2._wp/Web + 4._wp*Re_inv*fV)*fV/(fR**2._wp) f_Hdot = (fCpbw/(1._wp + fBtait) + 1._wp)**(-1._wp/fntait)*(tmp1 + tmp2) - (fCpinf/(1._wp + fBtait) + 1._wp) & - & **(-1._wp/fntait)*fCpinf_dot + & **(-1._wp/fntait)*fCpinf_dot + + ! Hdot = (Cpbw/(1+B) + 1)^(-1/n_tait)*(-3 gam)*(R0/R)^(3gam) V/R f_Hdot = + ! ((fCpbw/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*(-3._wp)*gam * & ( (fR0/fR)**(3._wp*gam ))*(fV/fR) - ! Hdot = (Cpbw/(1+B) + 1)^(-1/n_tait)*(-3 gam)*(R0/R)^(3gam) V/R - ! f_Hdot = ((fCpbw/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*(-3._wp)*gam * & - ! ( (fR0/fR)**(3._wp*gam ))*(fV/fR) + ! Hdot = Hdot - (Cpinf/(1+B) + 1)^(-1/n_tait) Cpinfdot f_Hdot = f_Hdot - + ! ((fCpinf/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*fCpinf_dot - ! Hdot = Hdot - (Cpinf/(1+B) + 1)^(-1/n_tait) Cpinfdot - ! f_Hdot = f_Hdot - ((fCpinf/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*fCpinf_dot end function f_Hdot !> Function that computes the bubble radial acceleration for Rayleigh-Plesset bubbles @@ -193,15 +205,16 @@ contains !! @param fV Current bubble velocity !! @param fCpbw Boundary wall pressure elemental function f_rddot_RP(fCp, fRho, fR, fV, fCpbw) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCp, fRho, fR, fV, fCpbw real(wp) :: f_rddot_RP - !! rddot = (1/r) ( -3/2 rdot^2 + ((r0/r)^3\gamma - Cp)/rho ) - !! rddot = (1/r) ( -3/2 rdot^2 + (tmp1 - Cp)/rho ) - !! rddot = (1/r) ( tmp2 ) + !! rddot = (1/r) ( -3/2 rdot^2 + ((r0/r)^3\gamma - Cp)/rho ) rddot = (1/r) ( -3/2 rdot^2 + (tmp1 - Cp)/rho ) rddot = (1/r) ( + !! tmp2 ) f_rddot_RP = (-1.5_wp*(fV**2._wp) + (fCpbw - fCp)/fRho)/fR + end function f_rddot_RP !> Function that computes the bubble radial acceleration @@ -214,6 +227,7 @@ contains !! @param fntait Tait EOS parameter !! @param fBtait Tait EOS parameter elemental function f_rddot_G(fCpbw, fR, fV, fH, fHdot, fcgas, fntait, fBtait) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fCpbw, fR, fV, fH, fHdot real(wp), intent(in) :: fcgas, fntait, fBtait @@ -225,6 +239,7 @@ contains tmp3 = 1.5_wp*fV**2._wp*(tmp1/3._wp - 1._wp) + fH*(1._wp + tmp1) + fR*fHdot*(1._wp - tmp1)/fcgas f_rddot_G = tmp3/(fR*(1._wp - tmp1)*tmp2) + end function f_rddot_G !> Function that computes the bubble wall pressure for Keller--Miksis bubbles @@ -233,6 +248,7 @@ contains !! @param fV Current bubble velocity !! @param fpb Internal bubble pressure elemental function f_cpbw_KM(fR0, fR, fV, fpb) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fR0, fR, fV, fpb real(wp) :: f_cpbw_KM @@ -246,6 +262,7 @@ contains if (.not. f_is_default(Web)) f_cpbw_KM = f_cpbw_KM - 2._wp/(fR*Web) if (.not. f_is_default(Re_inv)) f_cpbw_KM = f_cpbw_KM - 4._wp*Re_inv*fV/fR + end function f_cpbw_KM !> Function that computes the bubble radial acceleration for Keller--Miksis bubbles @@ -258,6 +275,7 @@ contains !! @param fR0 Equilibrium bubble radius !! @param fC Current sound speed elemental function f_rddot_KM(fpbdot, fCp, fCpbw, fRho, fR, fV, fR0, fC) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fpbdot, fCp, fCpbw real(wp), intent(in) :: fRho, fR, fV, fR0, fC @@ -281,12 +299,14 @@ contains else f_rddot_KM = tmp2/(fR*(1._wp - tmp1) + 4._wp*Re_inv/(fRho*fC)) end if + end function f_rddot_KM !> Subroutine that computes bubble wall properties for vapor bubbles !! @param pb_in Internal bubble pressure !! @param iR0 Current bubble size index elemental subroutine s_bwproperty(pb_in, iR0, chi_vw_out, k_mw_out, rho_mw_out) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: pb_in integer, intent(in) :: iR0 @@ -302,6 +322,7 @@ contains k_mw_out = x_vw*k_v(iR0)/(x_vw + (1._wp - x_vw)*phi_vg) + (1._wp - x_vw)*k_g(iR0)/(x_vw*phi_gv + 1._wp - x_vw) ! gas mixture density rho_mw_out = pv/(chi_vw_out*R_v*Tw) + end subroutine s_bwproperty !> Function that computes the vapour flux @@ -316,6 +337,7 @@ contains !! @param fR_m Mixture gas constant (EL) !! @param fgamma_m Mixture gamma (EL) elemental subroutine s_vflux(fR, fV, fpb, fmass_v, iR0, vflux, fmass_g, fbeta_c, fR_m, fgamma_m) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fR real(wp), intent(in) :: fV @@ -358,9 +380,10 @@ contains ! polytropic vflux = pv*fV/(R_v*Tw) end if + end subroutine s_vflux - !> Function that computes the time derivative of the internal bubble pressure + !> Function that computes the time derivative of the internal bubble pressure !! @param fvflux Vapour flux !! @param fR Current bubble radius !! @param fV Current bubble velocity @@ -371,6 +394,7 @@ contains !! @param fR_m Mixture gas constant (EL) !! @param fgamma_m Mixture gamma (EL) elemental function f_bpres_dot(fvflux, fR, fV, fpb, fmass_v, iR0, fbeta_t, fR_m, fgamma_m) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fvflux real(wp), intent(in) :: fR @@ -393,11 +417,12 @@ contains return end if grad_T = -Re_trans_T(iR0)*((fpb/pb0(iR0))*(fR/R0(iR0))**3*(mass_g0(iR0) + mass_v0(iR0))/(mass_g0(iR0) + fmass_v) & - & - 1._wp) + & - 1._wp) f_bpres_dot = 3._wp*gam_m*(-fV*fpb + fvflux*R_v*Tw + pb0(iR0)*k_mw*grad_T/Pe_T(iR0)/fR)/fR else f_bpres_dot = -3._wp*gam_m*fV/fR*(fpb - pv) end if + end function f_bpres_dot !> Adaptive time stepping routine for subgrid bubbles (See Heirer, E. Hairer S.P.Norsett G. Wanner, Solving Ordinary @@ -422,6 +447,7 @@ contains !! @param fCson Speed of sound (EL) !! @param adap_dt_stop Fail-safe exit if max iteration count reached subroutine s_advance_step(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, bub_id, fmass_v, & + & fmass_g, fbeta_c, fbeta_t, fCson, adap_dt_stop) $:GPU_ROUTINE(function_name='s_advance_step',parallelism='[seq]', cray_inline=True) @@ -458,7 +484,8 @@ contains ! Advance one sub-step call s_advance_substep(err(1), fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & - & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp1, myV_tmp1, myPb_tmp1, myMv_tmp1) + & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp1, myV_tmp1, myPb_tmp1, & + & myMv_tmp1) if (err(1) > adap_dt_tol) then h = 0.25_wp*h cycle @@ -466,7 +493,8 @@ contains ! Advance one sub-step by advancing two half steps call s_advance_substep(err(2), fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & - & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, myPb_tmp2, myMv_tmp2) + & bub_id, fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, & + & myPb_tmp2, myMv_tmp2) if (err(2) > adap_dt_tol) then h = 0.25_wp*h cycle @@ -476,7 +504,8 @@ contains fpb2 = myPb_tmp2(4); fmass_v2 = myMv_tmp2(4) call s_advance_substep(err(3), fRho, fP, fR2, fV2, fR0, fpb2, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, & - & bub_id, fmass_v2, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, myPb_tmp2, myMv_tmp2) + & bub_id, fmass_v2, fmass_g, fbeta_c, fbeta_t, fCson, 0.5_wp*h, myR_tmp2, myV_tmp2, & + & myPb_tmp2, myMv_tmp2) if (err(3) > adap_dt_tol) then h = 0.5_wp*h cycle @@ -486,11 +515,8 @@ contains err(5) = abs((myV_tmp1(4) - myV_tmp2(4))/myV_tmp1(4)) if (abs(myV_tmp1(4)) < verysmall) err(5) = 0._wp - ! Determine acceptance/rejection and update step size - ! Rule 1: err1, err2, err3 < tol - ! Rule 2: myR_tmp1(4) > 0._wp - ! Rule 3: abs((myR_tmp1(4) - myR_tmp2(4))/fR) < tol - ! Rule 4: abs((myV_tmp1(4) - myV_tmp2(4))/fV) < tol + ! Determine acceptance/rejection and update step size Rule 1: err1, err2, err3 < tol Rule 2: myR_tmp1(4) > 0._wp + ! Rule 3: abs((myR_tmp1(4) - myR_tmp2(4))/fR) < tol Rule 4: abs((myV_tmp1(4) - myV_tmp2(4))/fV) < tol if ((err(1) <= adap_dt_tol) .and. (err(2) <= adap_dt_tol) .and. (err(3) <= adap_dt_tol) .and. (err(4) & & <= adap_dt_tol) .and. (err(5) <= adap_dt_tol) .and. myR_tmp1(4) > 0._wp) then ! Accepted. Finalize the sub-step @@ -525,6 +551,7 @@ contains end do if (iter_count >= adap_dt_max_iters) adap_dt_stop = 1 + end subroutine s_advance_step !> Choose the initial time step size for the adaptive time stepping routine (See Heirer, E. Hairer S.P.Norsett G. Wanner, @@ -544,6 +571,7 @@ contains !! @param fCson Speed of sound (EL) !! @param h Time step size subroutine s_initial_substep_h(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson, h) + $:GPU_ROUTINE(function_name='s_initial_substep_h',parallelism='[seq]', cray_inline=True) real(wp), intent(in) :: fRho, fP, fR, fV, fR0, fpb, fpbdot, alf @@ -553,8 +581,7 @@ contains real(wp), dimension(2) :: h_size !< Time step size (h0, h1) real(wp), dimension(3) :: d_norms !< norms (d_0, d_1, d_2) real(wp), dimension(2) :: myR_tmp, myV_tmp, myA_tmp !< Bubble radius, radial velocity, and radial acceleration - ! Determine the starting time step - ! Evaluate f(x0,y0) + ! Determine the starting time step Evaluate f(x0,y0) myR_tmp(1) = fR myV_tmp(1) = fV myA_tmp(1) = f_rddot(fRho, fP, myR_tmp(1), myV_tmp(1), fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson) @@ -576,8 +603,7 @@ contains ! Compute d_2 = ||f(x0+h0,y0+h0*f(x0,y0))-f(x0,y0)||/h0 d_norms(3) = sqrt(((myV_tmp(2) - myV_tmp(1))**2._wp + (myA_tmp(2) - myA_tmp(1))**2._wp)/2._wp)/h_size(1) - ! Set h1 = (0.01/max(d_1,d_2))^{1/(p+1)} - ! if max(d_1,d_2) < 1.e-15_wp, h_size(2) = max(1.e-6_wp, h0*1.e-3_wp) + ! Set h1 = (0.01/max(d_1,d_2))^{1/(p+1)} if max(d_1,d_2) < 1.e-15_wp, h_size(2) = max(1.e-6_wp, h0*1.e-3_wp) if (max(d_norms(2), d_norms(3)) < threshold_second_guess) then h_size(2) = max(small_guess, h_size(1)*scale_first_guess) else @@ -585,9 +611,10 @@ contains end if h = min(h_size(1)/scale_guess, h_size(2)) + end subroutine s_initial_substep_h - !> Integrate bubble variables over the given time step size, h, using a third-order accurate embedded Runge-Kutta scheme. + !> Integrate bubble variables over the given time step size, h, using a third-order accurate embedded Runge-Kutta scheme. !! @param err Estimated error !! @param fRho Current density !! @param fP Current driving pressure @@ -613,6 +640,7 @@ contains !! @param myPb_tmp Internal bubble pressure at each stage (EL) !! @param myMv_tmp Mass of vapor in the bubble at each stage (EL) subroutine s_advance_substep(err, fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, bub_id, & + & fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp, myV_tmp, myPb_tmp, myMv_tmp) $:GPU_ROUTINE(function_name='s_advance_substep',parallelism='[seq]', cray_inline=True) @@ -635,10 +663,10 @@ contains myPb_tmp(1) = fpb myMv_tmp(1) = fmass_v call s_advance_EL(myR_tmp(1), myV_tmp(1), myPb_tmp(1), myMv_tmp(1), bub_id, fmass_g, fbeta_c, fbeta_t, & - & mydPbdt_tmp(1), mydMvdt_tmp(1)) + & mydPbdt_tmp(1), mydMvdt_tmp(1)) end if myA_tmp(1) = f_rddot(fRho, fP, myR_tmp(1), myV_tmp(1), fR0, myPb_tmp(1), mydPbdt_tmp(1), alf, fntait, fBtait, & - & f_bub_adv_src, f_divu, fCson) + & f_bub_adv_src, f_divu, fCson) ! Stage 1 myR_tmp(2) = myR_tmp(1) + h*myV_tmp(1) @@ -650,10 +678,10 @@ contains myPb_tmp(2) = myPb_tmp(1) + h*mydPbdt_tmp(1) myMv_tmp(2) = myMv_tmp(1) + h*mydMvdt_tmp(1) call s_advance_EL(myR_tmp(2), myV_tmp(2), myPb_tmp(2), myMv_tmp(2), bub_id, fmass_g, fbeta_c, fbeta_t, & - & mydPbdt_tmp(2), mydMvdt_tmp(2)) + & mydPbdt_tmp(2), mydMvdt_tmp(2)) end if myA_tmp(2) = f_rddot(fRho, fP, myR_tmp(2), myV_tmp(2), fR0, myPb_tmp(2), mydPbdt_tmp(2), alf, fntait, fBtait, & - & f_bub_adv_src, f_divu, fCson) + & f_bub_adv_src, f_divu, fCson) ! Stage 2 myR_tmp(3) = myR_tmp(1) + (h/4._wp)*(myV_tmp(1) + myV_tmp(2)) @@ -665,10 +693,10 @@ contains myPb_tmp(3) = myPb_tmp(1) + (h/4._wp)*(mydPbdt_tmp(1) + mydPbdt_tmp(2)) myMv_tmp(3) = myMv_tmp(1) + (h/4._wp)*(mydMvdt_tmp(1) + mydMvdt_tmp(2)) call s_advance_EL(myR_tmp(3), myV_tmp(3), myPb_tmp(3), myMv_tmp(3), bub_id, fmass_g, fbeta_c, fbeta_t, & - & mydPbdt_tmp(3), mydMvdt_tmp(3)) + & mydPbdt_tmp(3), mydMvdt_tmp(3)) end if myA_tmp(3) = f_rddot(fRho, fP, myR_tmp(3), myV_tmp(3), fR0, myPb_tmp(3), mydPbdt_tmp(3), alf, fntait, fBtait, & - & f_bub_adv_src, f_divu, fCson) + & f_bub_adv_src, f_divu, fCson) ! Stage 3 myR_tmp(4) = myR_tmp(1) + (h/6._wp)*(myV_tmp(1) + myV_tmp(2) + 4._wp*myV_tmp(3)) @@ -680,10 +708,10 @@ contains myPb_tmp(4) = myPb_tmp(1) + (h/6._wp)*(mydPbdt_tmp(1) + mydPbdt_tmp(2) + 4._wp*mydPbdt_tmp(3)) myMv_tmp(4) = myMv_tmp(1) + (h/6._wp)*(mydMvdt_tmp(1) + mydMvdt_tmp(2) + 4._wp*mydMvdt_tmp(3)) call s_advance_EL(myR_tmp(4), myV_tmp(4), myPb_tmp(4), myMv_tmp(4), bub_id, fmass_g, fbeta_c, fbeta_t, & - & mydPbdt_tmp(4), mydMvdt_tmp(4)) + & mydPbdt_tmp(4), mydMvdt_tmp(4)) end if myA_tmp(4) = f_rddot(fRho, fP, myR_tmp(4), myV_tmp(4), fR0, myPb_tmp(4), mydPbdt_tmp(4), alf, fntait, fBtait, & - & f_bub_adv_src, f_divu, fCson) + & f_bub_adv_src, f_divu, fCson) ! Estimate error err_R = (-5._wp*h/24._wp)*(myV_tmp(2) + myV_tmp(3) - 2._wp*myV_tmp(4))/max(abs(myR_tmp(1)), abs(myR_tmp(4))) @@ -697,6 +725,7 @@ contains err_V = 0._wp end if err = sqrt((err_R**2._wp + err_V**2._wp)/2._wp) + end subroutine s_advance_substep !> Changes of pressure and vapor mass in the lagrange bubbles. @@ -711,6 +740,7 @@ contains !! @param fdPbdt_tmp Rate of change of the internal bubble pressure !! @param advance_EL Rate of change of the mass of vapor in the bubble elemental subroutine s_advance_EL(fR_tmp, fV_tmp, fPb_tmp, fMv_tmp, bub_id, fmass_g, fbeta_c, fbeta_t, fdPbdt_tmp, advance_EL) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: fR_tmp, fV_tmp, fPb_tmp, fMv_tmp real(wp), intent(in) :: fmass_g, fbeta_c, fbeta_t @@ -722,5 +752,7 @@ contains call s_vflux(fR_tmp, fV_tmp, fPb_tmp, fMv_tmp, bub_id, fVapFlux, fmass_g, fbeta_c, myR_m, mygamma_m) fdPbdt_tmp = f_bpres_dot(fVapFlux, fR_tmp, fV_tmp, fPb_tmp, fMv_tmp, bub_id, fbeta_t, myR_m, mygamma_m) advance_EL = 4._wp*pi*fR_tmp**2._wp*fVapFlux + end subroutine s_advance_EL + end module m_bubbles diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index 4626ac5e9b..47d4bade61 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -6,11 +6,12 @@ !> @brief Computes ensemble-averaged (Euler--Euler) bubble source terms for radius, velocity, pressure, and mass transfer module m_bubbles_EE - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_bubbles !< General bubble dynamics procedures + use m_bubbles !< General bubble dynamics procedures implicit none real(wp), allocatable, dimension(:,:,:) :: bub_adv_src @@ -22,10 +23,12 @@ module m_bubbles_EE integer, allocatable, dimension(:) :: rs, vs, ms, ps $:GPU_DECLARE(create='[rs, vs, ms, ps]') + contains !> @brief Allocates and initializes arrays for the Euler-Euler bubble model. impure subroutine s_initialize_bubbles_EE_module + integer :: l @:ALLOCATE(rs(1:nb)) @@ -58,11 +61,13 @@ contains @:ALLOCATE(bub_m_src(0:m, 0:n, 0:p, 1:nb)) if (adap_dt .and. f_is_default(adap_dt_tol)) adap_dt_tol = dflt_adap_dt_tol + end subroutine s_initialize_bubbles_EE_module !> @brief Computes the bubble volume fraction alpha from the bubble number density. - !! @param q_cons_vf is the conservative variable + !! @param q_cons_vf is the conservative variable subroutine s_comp_alpha_from_n(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf real(wp) :: nR3bar integer(wp) :: i, j, k, l @@ -81,12 +86,14 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_comp_alpha_from_n !> Compute the right-hand side for Euler-Euler bubble transport - !! @param idir Direction index - !! @param q_prim_vf Primitive variables + !! @param idir Direction index + !! @param q_prim_vf Primitive variables subroutine s_compute_bubbles_EE_rhs(idir, q_prim_vf, divu_in) + integer, intent(in) :: idir type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), intent(inout) :: divu_in !< matrix for div(u) @@ -100,7 +107,7 @@ contains do j = 0, m divu_in%sf(j, k, l) = 0._wp divu_in%sf(j, k, l) = 5.e-1_wp/dx(j)*(q_prim_vf(contxe + idir)%sf(j + 1, k, & - & l) - q_prim_vf(contxe + idir)%sf(j - 1, k, l)) + & l) - q_prim_vf(contxe + idir)%sf(j - 1, k, l)) end do end do end do @@ -112,7 +119,7 @@ contains do k = 0, n do j = 0, m divu_in%sf(j, k, l) = divu_in%sf(j, k, l) + 5.e-1_wp/dy(k)*(q_prim_vf(contxe + idir)%sf(j, k + 1, & - & l) - q_prim_vf(contxe + idir)%sf(j, k - 1, l)) + & l) - q_prim_vf(contxe + idir)%sf(j, k - 1, l)) end do end do end do @@ -123,19 +130,21 @@ contains do k = 0, n do j = 0, m divu_in%sf(j, k, l) = divu_in%sf(j, k, l) + 5.e-1_wp/dz(l)*(q_prim_vf(contxe + idir)%sf(j, k, & - & l + 1) - q_prim_vf(contxe + idir)%sf(j, k, l - 1)) + & l + 1) - q_prim_vf(contxe + idir)%sf(j, k, l - 1)) end do end do end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_compute_bubbles_EE_rhs - !> The purpose of this procedure is to compute the source terms that are needed for the bubble modeling + !> The purpose of this procedure is to compute the source terms that are needed for the bubble modeling !! @param q_prim_vf Primitive variables !! @param q_cons_vf Conservative variables !! @param rhs_vf Right-hand side variables impure subroutine s_compute_bubble_EE_source(q_cons_vf, q_prim_vf, rhs_vf, divu_in) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf @@ -178,8 +187,8 @@ contains adap_dt_stop_max = 0 $:GPU_PARALLEL_LOOP(private='[j, k, l, Rtmp, Vtmp, myalpha_rho, myalpha, myR, myV, alf, myP, myRho, R2Vav, R3, nbub, & - & pb_local, mv_local, vflux, pbdot, rddot, n_tait, B_tait, my_divu]', collapse=3, & - & reduction = '[[adap_dt_stop_max]]', reductionOp = '[MAX]', copy = '[adap_dt_stop_max]') + & pb_local, mv_local, vflux, pbdot, rddot, n_tait, B_tait, my_divu]', collapse=3, & + & reduction = '[[adap_dt_stop_max]]', reductionOp = '[MAX]', copy = '[adap_dt_stop_max]') do l = 0, p do k = 0, n do j = 0, m @@ -272,8 +281,8 @@ contains adap_dt_stop = 0 call s_advance_step(myRho, myP, myR, myV, R0(q), pb_local, pbdot, alf, n_tait, B_tait, & - & bub_adv_src(j, k, l), divu_in%sf(j, k, l), dmBub_id, dmMass_v, dmMass_n, dmBeta_c, & - & dmBeta_t, dmCson, adap_dt_stop) + & bub_adv_src(j, k, l), divu_in%sf(j, k, l), dmBub_id, dmMass_v, dmMass_n, & + & dmBeta_c, dmBeta_t, dmCson, adap_dt_stop) q_cons_vf(rs(q))%sf(j, k, l) = nbub*myR q_cons_vf(vs(q))%sf(j, k, l) = nbub*myV @@ -281,7 +290,7 @@ contains adap_dt_stop_max = max(adap_dt_stop_max, adap_dt_stop) else rddot = f_rddot(myRho, myP, myR, myV, R0(q), pb_local, pbdot, alf, n_tait, B_tait, bub_adv_src(j, & - & k, l), divu_in%sf(j, k, l), dmCson) + & k, l), divu_in%sf(j, k, l), dmCson) bub_v_src(j, k, l, q) = nbub*rddot bub_r_src(j, k, l, q) = q_cons_vf(vs(q))%sf(j, k, l) end if @@ -315,5 +324,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_compute_bubble_EE_source + end module m_bubbles_EE diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 62433c865f..949d42cd4f 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -6,14 +6,15 @@ !> @brief Tracks Lagrangian bubbles and couples their dynamics to the Eulerian flow via volume averaging module m_bubbles_EL - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_bubbles_EL_kernels !< Definitions of the kernel functions - use m_bubbles !< General bubble dynamics procedures + + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_bubbles_EL_kernels !< Definitions of the kernel functions + use m_bubbles !< General bubble dynamics procedures use m_variables_conversion !< State variables type conversion procedures use m_compile_specific use m_boundary_common - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_sim_helpers use m_helper @@ -58,19 +59,22 @@ module m_bubbles_EL integer :: nBubs !< Number of bubbles in the local domain real(wp) :: Rmax_glb, Rmin_glb !< Maximum and minimum bubbe size in the local domain - !< Projection of the lagrangian particles in the Eulerian framework + !> Projection of the lagrangian particles in the Eulerian framework type(scalar_field), dimension(:), allocatable :: q_beta integer :: q_beta_idx !< Size of the q_beta vector field $:GPU_DECLARE(create='[nBubs, Rmax_glb, Rmin_glb, q_beta, q_beta_idx]') + contains !> Initializes the lagrangian subgrid bubble solver - !! @param q_cons_vf Initial conservative variables + !! @param q_cons_vf Initial conservative variables impure subroutine s_initialize_bubbles_EL_module(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf integer :: nBubs_glb, i ! Setting number of time-stages for selected time-stepping scheme + lag_num_ts = time_stepper ! Allocate space for the Eulerian fields needed to map the effect of the bubbles @@ -130,11 +134,13 @@ contains ! Starting bubbles call s_read_input_bubbles(q_cons_vf) + end subroutine s_initialize_bubbles_EL_module !> The purpose of this procedure is to obtain the initial bubbles' information - !! @param q_cons_vf Conservative variables + !! @param q_cons_vf Conservative variables impure subroutine s_read_input_bubbles(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf real(wp), dimension(8) :: inputBubble real(wp) :: qtime @@ -143,6 +149,7 @@ contains logical :: file_exist, indomain character(LEN=path_len + 2*name_len) :: path_D_dir ! Initialize number of particles + bub_id = 0 id = 0 @@ -190,8 +197,9 @@ contains $:GPU_UPDATE(device='[bubbles_lagrange, lag_params]') $:GPU_UPDATE(device='[lag_id, bub_R0, Rmax_stats, Rmin_stats, gas_mg, gas_betaT, gas_betaC, bub_dphidt, gas_p, gas_mv, & - & intfc_rad, intfc_vel, mtn_pos, mtn_posPrev, mtn_vel, mtn_s, intfc_draddt, intfc_dveldt, gas_dpdt, gas_dmvdt, & - & mtn_dposdt, mtn_dveldt, nBubs]') + & intfc_rad, intfc_vel, mtn_pos, mtn_posPrev, mtn_vel, mtn_s, intfc_draddt, intfc_dveldt, gas_dpdt, & + & gas_dmvdt, & + & mtn_dposdt, mtn_dveldt, nBubs]') Rmax_glb = min(dflt_real, -dflt_real) Rmin_glb = max(dflt_real, -dflt_real) @@ -213,13 +221,15 @@ contains call s_write_restart_lag_bubbles(save_count) ! Needed for post_processing call s_write_void_evol(qtime) end if + end subroutine s_read_input_bubbles !> The purpose of this procedure is to obtain the information of the bubbles when starting fresh - !! @param inputBubble Bubble information - !! @param q_cons_vf Conservative variables - !! @param bub_id Local id of the bubble + !! @param inputBubble Bubble information + !! @param q_cons_vf Conservative variables + !! @param bub_id Local id of the bubble impure subroutine s_add_bubbles(inputBubble, q_cons_vf, bub_id) + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf real(wp), dimension(8), intent(in) :: inputBubble integer, intent(in) :: bub_id @@ -322,12 +332,14 @@ contains if (gas_mg(bub_id) <= 0._wp) then call s_mpi_abort("Negative gas mass in the bubble, check if the bubble is in the domain.") end if + end subroutine s_add_bubbles !> The purpose of this procedure is to obtain the information of the bubbles from a restart point. - !! @param bub_id Local ID of the particle - !! @param save_count File identifier + !! @param bub_id Local ID of the particle + !! @param save_count File identifier impure subroutine s_restart_bubbles(bub_id, save_count) + integer, intent(inout) :: bub_id, save_count character(LEN=path_len + 2*name_len) :: file_loc real(wp) :: file_time, file_dt @@ -345,6 +357,7 @@ contains integer :: i integer, dimension(:), allocatable :: proc_bubble_counts real(wp), dimension(1:1, 1:lag_io_vars) :: dummy + dummy = 0._wp ! Construct file path @@ -418,7 +431,7 @@ contains ! Skip extended header disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lag_bubbles, lag_io_vars*bub_id, mpi_p, status, ierr) @@ -459,7 +472,7 @@ contains ! Skip extended header disp = int(sizeof(file_tot_part) + 2*sizeof(file_time) + sizeof(file_num_procs) & - & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) + & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_READ_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -475,12 +488,14 @@ contains deallocate (proc_bubble_counts) #endif + end subroutine s_restart_bubbles !> Contains the bubble dynamics subroutines. - !! @param q_prim_vf Primitive variables - !! @param stage Current stage in the time-stepper algorithm + !! @param q_prim_vf Primitive variables + !! @param stage Current stage in the time-stepper algorithm subroutine s_compute_bubble_EL_dynamics(q_prim_vf, stage) + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer, intent(in) :: stage real(wp) :: myVapFlux @@ -495,10 +510,10 @@ contains real(wp), dimension(num_fluids) :: myalpha_rho, myalpha #:endif real(wp), dimension(2) :: Re - integer, dimension(3) :: cell - integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached - real(wp) :: dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu !< Dummy variables for unified subgrid bubble subroutines - integer :: i, k, l + integer, dimension(3) :: cell + integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached + real(wp) :: dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu !< Dummy variables for unified subgrid bubble subroutines + integer :: i, k, l call nvtxStartRange("LAGRANGE-BUBBLE-DYNAMICS") @@ -516,8 +531,8 @@ contains pint = pint + 0.5_wp*myV**2._wp if (lag_params%cluster_type == 2) then bub_dphidt(k) = (paux - pint) + term2 - ! Accounting for the potential induced by the bubble averaged over the control volume - ! Note that this is based on the incompressible flow assumption near the bubble. + ! Accounting for the potential induced by the bubble averaged over the control volume Note that this is based on + ! the incompressible flow assumption near the bubble. term1_fac = 3._wp/2._wp*(myR*(Romega**2._wp - myR**2._wp))/(Romega**3._wp - myR**3._wp) bub_dphidt(k) = bub_dphidt(k)/(1._wp - term1_fac) end if @@ -528,10 +543,10 @@ contains ! Radial motion model adap_dt_stop_max = 0 $:GPU_PARALLEL_LOOP(private='[k, i, myalpha_rho, myalpha, Re, cell, myVapFlux, preterm1, term2, paux, pint, Romega, & - & term1_fac, myR_m, mygamma_m, myPb, myMass_n, myMass_v, myR, myV, myBeta_c, myBeta_t, myR0, myPbdot, myMvdot, myPinf, & - & aux1, aux2, myCson, myRho, gamma, pi_inf, qv, dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu, & - & adap_dt_stop]', reduction='[[adap_dt_stop_max]]',reductionOp='[MAX]', & - & copy = '[adap_dt_stop_max]', copyin = '[stage]') + & term1_fac, myR_m, mygamma_m, myPb, myMass_n, myMass_v, myR, myV, myBeta_c, myBeta_t, myR0, myPbdot, & + & myMvdot, myPinf, aux1, aux2, myCson, myRho, gamma, pi_inf, qv, dmalf, dmntait, dmBtait, & + & dm_bub_adv_src, dm_divu, adap_dt_stop]', reduction='[[adap_dt_stop_max]]',reductionOp='[MAX]', & + & copy = '[adap_dt_stop_max]', copyin = '[stage]') do k = 1, nBubs ! Keller-Miksis model @@ -563,7 +578,7 @@ contains if (adap_dt) then call s_advance_step(myRho, myPinf, myR, myV, myR0, myPb, myPbdot, dmalf, dmntait, dmBtait, dm_bub_adv_src, & - & dm_divu, k, myMass_v, myMass_n, myBeta_c, myBeta_t, myCson, adap_dt_stop) + & dm_divu, k, myMass_v, myMass_n, myBeta_c, myBeta_t, myCson, adap_dt_stop) ! Update bubble state intfc_rad(k, 1) = myR @@ -574,7 +589,7 @@ contains ! Radial acceleration from bubble models intfc_dveldt(k, stage) = f_rddot(myRho, myPinf, myR, myV, myR0, myPb, myPbdot, dmalf, dmntait, dmBtait, & - & dm_bub_adv_src, dm_divu, myCson) + & dm_bub_adv_src, dm_divu, myCson) intfc_draddt(k, stage) = myV gas_dmvdt(k, stage) = myMvdot gas_dpdt(k, stage) = myPbdot @@ -597,14 +612,16 @@ contains $:END_GPU_PARALLEL_LOOP() call nvtxEndRange + end subroutine s_compute_bubble_EL_dynamics !> The purpose of this subroutine is to obtain the bubble source terms based on Maeda and Colonius (2018) and add them to the !! RHS scalar field. - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Conservative variables - !! @param rhs_vf Time derivative of the conservative variables + !! @param q_cons_vf Conservative variables + !! @param q_prim_vf Conservative variables + !! @param rhs_vf Time derivative of the conservative variables subroutine s_compute_bubbles_EL_source(q_cons_vf, q_prim_vf, rhs_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf @@ -622,7 +639,7 @@ contains do l = 1, E_idx if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then rhs_vf(l)%sf(i, j, k) = rhs_vf(l)%sf(i, j, k) + q_cons_vf(l)%sf(i, j, k)*(q_beta(2)%sf(i, j, & - & k) + q_beta(5)%sf(i, j, k)) + & k) + q_beta(5)%sf(i, j, k)) end if end do end do @@ -637,7 +654,7 @@ contains do l = 1, E_idx if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then rhs_vf(l)%sf(i, j, k) = rhs_vf(l)%sf(i, j, k) + q_cons_vf(l)%sf(i, j, k)/q_beta(1)%sf(i, j, & - & k)*q_beta(2)%sf(i, j, k) + & k)*q_beta(2)%sf(i, j, k) end if end do end do @@ -656,7 +673,7 @@ contains do i = 0, m if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then rhs_vf(contxe + l)%sf(i, j, k) = rhs_vf(contxe + l)%sf(i, j, k) - (1._wp - q_beta(1)%sf(i, j, & - & k))/q_beta(1)%sf(i, j, k)*q_beta(3)%sf(i, j, k) + & k))/q_beta(1)%sf(i, j, k)*q_beta(3)%sf(i, j, k) end if end do end do @@ -683,7 +700,7 @@ contains do i = 0, m if (q_beta(1)%sf(i, j, k) > (1._wp - lag_params%valmaxvoid)) then rhs_vf(E_idx)%sf(i, j, k) = rhs_vf(E_idx)%sf(i, j, k) - q_beta(4)%sf(i, j, & - & k)*(1._wp - q_beta(1)%sf(i, j, k))/q_beta(1)%sf(i, j, k) + & k)*(1._wp - q_beta(1)%sf(i, j, k))/q_beta(1)%sf(i, j, k) end if end do end do @@ -691,17 +708,19 @@ contains $:END_GPU_PARALLEL_LOOP() end do end if + end subroutine s_compute_bubbles_EL_source !> This procedure computes the speed of sound from a given driving pressure - !! @param q_prim_vf Primitive variables - !! @param pinf Driving pressure - !! @param cell Bubble cell - !! @param rhol Liquid density - !! @param gamma Liquid specific heat ratio - !! @param pi_inf Liquid stiffness - !! @param cson Calculated speed of sound + !! @param q_prim_vf Primitive variables + !! @param pinf Driving pressure + !! @param cell Bubble cell + !! @param rhol Liquid density + !! @param gamma Liquid specific heat ratio + !! @param pi_inf Liquid stiffness + !! @param cson Calculated speed of sound subroutine s_compute_cson_from_pinf(q_prim_vf, pinf, cell, rhol, gamma, pi_inf, cson) + $:GPU_ROUTINE(function_name='s_compute_cson_from_pinf', parallelism='[seq]', cray_inline=True) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -724,10 +743,12 @@ contains E = gamma*pinf + pi_inf + 0.5_wp*rhol*dot_product(vel, vel) H = (E + pinf)/rhol cson = sqrt((H - 0.5_wp*dot_product(vel, vel))/gamma) + end subroutine s_compute_cson_from_pinf !> The purpose of this subroutine is to smear the effect of the bubbles in the Eulerian framework subroutine s_smear_voidfraction() + integer :: i, j, k, l call nvtxStartRange("BUBBLES-LAGRANGE-KERNELS") @@ -760,18 +781,20 @@ contains $:END_GPU_PARALLEL_LOOP() call nvtxEndRange + end subroutine s_smear_voidfraction !> The purpose of this procedure is obtain the bubble driving pressure p_inf - !! @param bub_id Particle identifier - !! @param q_prim_vf Primitive variables - !! @param ptype 1: p at infinity, 2: averaged P at the bubble location - !! @param f_pinfl Driving pressure - !! @param cell Bubble cell - !! @param preterm1 Pre-computed term 1 - !! @param term2 Computed term 2 - !! @param Romega Control volume radius + !! @param bub_id Particle identifier + !! @param q_prim_vf Primitive variables + !! @param ptype 1: p at infinity, 2: averaged P at the bubble location + !! @param f_pinfl Driving pressure + !! @param cell Bubble cell + !! @param preterm1 Pre-computed term 1 + !! @param term2 Computed term 2 + !! @param Romega Control volume radius subroutine s_get_pinf(bub_id, q_prim_vf, ptype, f_pinfl, cell, preterm1, term2, Romega) + $:GPU_ROUTINE(function_name='s_get_pinf',parallelism='[seq]', cray_inline=True) integer, intent(in) :: bub_id, ptype @@ -791,7 +814,7 @@ contains scoord = mtn_s(bub_id, 1:3, 2) f_pinfl = 0._wp - !< Find current bubble cell + !> Find current bubble cell cell(:) = int(scoord(:)) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -799,8 +822,8 @@ contains end do if ((lag_params%cluster_type == 1)) then - !< Getting p_cell in terms of only the current cell by interpolation - !< Getting the cell volulme as Omega + !> Getting p_cell in terms of only the current cell by interpolation + !> Getting the cell volulme as Omega if (p > 0) then vol = dx(cell(1))*dy(cell(2))*dz(cell(3)) else @@ -811,7 +834,7 @@ contains end if end if - !< Obtain bilinear interpolation coefficients, based on the current location of the bubble. + !> Obtain bilinear interpolation coefficients, based on the current location of the bubble. psi(1) = (scoord(1) - real(cell(1)))*dx(cell(1)) + x_cb(cell(1) - 1) if (cell(1) == (m + buff_size)) then cell(1) = cell(1) - 1 @@ -849,7 +872,7 @@ contains psi(3) = 0._wp end if - !< Perform bilinear interpolation + !> Perform bilinear interpolation if (p == 0) then ! 2D f_pinfl = q_prim_vf(E_idx)%sf(cell(1), cell(2), cell(3))*(1._wp - psi(1))*(1._wp - psi(2)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2), cell(3))*psi(1)*(1._wp - psi(2)) @@ -893,7 +916,7 @@ contains cellaux(3) = cell(3) + k - (mapCells + 1) if (p == 0) cellaux(3) = 0 - !< check if the current cell is outside the computational domain or not (including ghost cells) + !> check if the current cell is outside the computational domain or not (including ghost cells) celloutside = .false. if (num_dims == 2) then if ((cellaux(1) < -buff_size) .or. (cellaux(2) < -buff_size)) then @@ -922,7 +945,7 @@ contains end if if (.not. celloutside) then - !< Obtaining the cell volulme + !> Obtaining the cell volulme if (p > 0) then vol = dx(cellaux(1))*dy(cellaux(2))*dz(cellaux(3)) else @@ -932,12 +955,12 @@ contains vol = dx(cellaux(1))*dy(cellaux(2))*lag_params%charwidth end if end if - !< Update values + !> Update values charvol = charvol + vol charpres = charpres + q_prim_vf(E_idx)%sf(cellaux(1), cellaux(2), cellaux(3))*vol charvol2 = charvol2 + vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) charpres2 = charpres2 + q_prim_vf(E_idx)%sf(cellaux(1), cellaux(2), & - & cellaux(3))*vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) + & cellaux(3))*vol*q_beta(1)%sf(cellaux(1), cellaux(2), cellaux(3)) end if end do end do @@ -969,12 +992,14 @@ contains f_pinfl = f_pinfl + preterm1*term1 + term2 end if end if + end subroutine s_get_pinf !> This subroutine updates the Lagrange variables using the tvd RK time steppers. The time derivative of the bubble variables !! must be stored at every stage to avoid precision errors. - !! @param stage Current tvd RK stage + !! @param stage Current tvd RK stage impure subroutine s_update_lagrange_tdv_rk(stage) + integer, intent(in) :: stage integer :: k @@ -1064,13 +1089,13 @@ contains do k = 1, nBubs ! u{n+1} = u{n} + (2/3) * dt * [(1/4)* RHS{n} + (1/4)* RHS{1} + RHS{2}] intfc_rad(k, 1) = intfc_rad(k, 1) + (2._wp/3._wp)*dt*(intfc_draddt(k, 1)/4._wp + intfc_draddt(k, & - & 2)/4._wp + intfc_draddt(k, 3)) + & 2)/4._wp + intfc_draddt(k, 3)) intfc_vel(k, 1) = intfc_vel(k, 1) + (2._wp/3._wp)*dt*(intfc_dveldt(k, 1)/4._wp + intfc_dveldt(k, & - & 2)/4._wp + intfc_dveldt(k, 3)) + & 2)/4._wp + intfc_dveldt(k, 3)) mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dposdt(k, 1:3, 1)/4._wp + mtn_dposdt(k, 1:3, & - & 2)/4._wp + mtn_dposdt(k, 1:3, 3)) + & 2)/4._wp + mtn_dposdt(k, 1:3, 3)) mtn_vel(k, 1:3, 1) = mtn_vel(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dveldt(k, 1:3, 1)/4._wp + mtn_dveldt(k, 1:3, & - & 2)/4._wp + mtn_dveldt(k, 1:3, 3)) + & 2)/4._wp + mtn_dveldt(k, 1:3, 3)) gas_p(k, 1) = gas_p(k, 1) + (2._wp/3._wp)*dt*(gas_dpdt(k, 1)/4._wp + gas_dpdt(k, 2)/4._wp + gas_dpdt(k, 3)) gas_mv(k, 1) = gas_mv(k, 1) + (2._wp/3._wp)*dt*(gas_dmvdt(k, 1)/4._wp + gas_dmvdt(k, 2)/4._wp + gas_dmvdt(k, 3)) end do @@ -1086,13 +1111,15 @@ contains end if end if end if + end subroutine s_update_lagrange_tdv_rk !> This subroutine returns the computational coordinate of the cell for the given position. - !! @param pos Input coordinates - !! @param cell Computational coordinate of the cell - !! @param scoord Calculated particle coordinates + !! @param pos Input coordinates + !! @param cell Computational coordinate of the cell + !! @param scoord Calculated particle coordinates subroutine s_locate_cell(pos, cell, scoord) + real(wp), dimension(3), intent(in) :: pos real(wp), dimension(3), intent(out) :: scoord integer, dimension(3), intent(inout) :: cell @@ -1123,11 +1150,9 @@ contains end do end if - ! The numbering of the cell of which left boundary is the domain boundary is 0. - ! if comp.coord of the pos is s, the real coordinate of s is - ! (the coordinate of the left boundary of the Floor(s)-th cell) - ! + (s-(int(s))*(cell-width). - ! In other words, the coordinate of the center of the cell is x_cc(cell). + ! The numbering of the cell of which left boundary is the domain boundary is 0. if comp.coord of the pos is s, the real + ! coordinate of s is (the coordinate of the left boundary of the Floor(s)-th cell) + (s-(int(s))*(cell-width). In other + ! words, the coordinate of the center of the cell is x_cc(cell). ! coordinates in computational space scoord(1) = cell(1) + (pos(1) - x_cb(cell(1) - 1))/dx(cell(1)) @@ -1138,10 +1163,12 @@ contains do i = 1, num_dims if (scoord(i) < 0._wp) cell(i) = cell(i) - 1 end do + end subroutine s_locate_cell !> This subroutine transfer data into the temporal variables. impure subroutine s_transfer_data_to_tmp() + integer :: k $:GPU_PARALLEL_LOOP(private='[k]') @@ -1156,33 +1183,37 @@ contains mtn_s(k, 1:3, 2) = mtn_s(k, 1:3, 1) end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_transfer_data_to_tmp !> The purpose of this procedure is to determine if the global coordinates of the bubbles are present in the current MPI !! processor (including ghost cells). - !! @param pos_part Spatial coordinates of the bubble + !! @param pos_part Spatial coordinates of the bubble function particle_in_domain(pos_part) + logical :: particle_in_domain real(wp), dimension(3), intent(in) :: pos_part ! 2D + if (p == 0 .and. cyl_coord .neqv. .true.) then - ! Defining a virtual z-axis that has the same dimensions as y-axis - ! defined in the input file + ! Defining a virtual z-axis that has the same dimensions as y-axis defined in the input file particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & - & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) .and. (pos_part(3) & - & < lag_params%charwidth/2._wp) .and. (pos_part(3) >= -lag_params%charwidth/2._wp)) + & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) & + & .and. (pos_part(3) < lag_params%charwidth/2._wp) .and. (pos_part(3) >= & + & -lag_params%charwidth/2._wp)) else ! cyl_coord particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & - & .and. (abs(pos_part(2)) < y_cb(n + buff_size)) .and. (abs(pos_part(2)) >= max(y_cb(-buff_size - 1), 0._wp))) + & .and. (abs(pos_part(2)) < y_cb(n + buff_size)) .and. (abs(pos_part(2)) >= max(y_cb(-buff_size & + & - 1), 0._wp))) end if ! 3D if (p > 0) then particle_in_domain = ((pos_part(1) < x_cb(m + buff_size)) .and. (pos_part(1) >= x_cb(-buff_size - 1)) & - & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) .and. (pos_part(3) & - & < z_cb(p + buff_size)) .and. (pos_part(3) >= z_cb(-buff_size - 1))) + & .and. (pos_part(2) < y_cb(n + buff_size)) .and. (pos_part(2) >= y_cb(-buff_size - 1)) & + & .and. (pos_part(3) < z_cb(p + buff_size)) .and. (pos_part(3) >= z_cb(-buff_size - 1))) end if ! For symmetric and wall boundary condition @@ -1206,30 +1237,34 @@ contains particle_in_domain = (particle_in_domain .and. (pos_part(3) < z_cb(p))) end if end if + end function particle_in_domain !> The purpose of this procedure is to determine if the lagrangian bubble is located in the physical domain. The ghost cells are !! not part of the physical domain. - !! @param pos_part Spatial coordinates of the bubble + !! @param pos_part Spatial coordinates of the bubble function particle_in_domain_physical(pos_part) + logical :: particle_in_domain_physical real(wp), dimension(3), intent(in) :: pos_part particle_in_domain_physical = ((pos_part(1) < x_cb(m)) .and. (pos_part(1) >= x_cb(-1)) .and. (pos_part(2) < y_cb(n)) & - & .and. (pos_part(2) >= y_cb(-1))) + & .and. (pos_part(2) >= y_cb(-1))) if (p > 0) then particle_in_domain_physical = (particle_in_domain_physical .and. (pos_part(3) < z_cb(p)) .and. (pos_part(3) & - & >= z_cb(-1))) + & >= z_cb(-1))) end if + end function particle_in_domain_physical !> The purpose of this procedure is to calculate the gradient of a scalar field along the x, y and z directions following a !! second-order central difference considering uneven widths - !! @param q Input scalar field - !! @param dq Output gradient of q - !! @param dir Gradient spatial direction + !! @param q Input scalar field + !! @param dq Output gradient of q + !! @param dir Gradient spatial direction subroutine s_gradient_dir(q, dq, dir) + real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:), intent(inout) :: q, dq integer, intent(in) :: dir integer :: i, j, k @@ -1241,7 +1276,7 @@ contains do j = 0, n do i = 0, m dq(i, j, k) = q(i, j, k)*(dx(i + 1) - dx(i - 1)) + q(i + 1, j, k)*(dx(i) + dx(i - 1)) - q(i - 1, j, & - & k)*(dx(i) + dx(i + 1)) + & k)*(dx(i) + dx(i + 1)) dq(i, j, k) = dq(i, j, k)/((dx(i) + dx(i - 1))*(dx(i) + dx(i + 1))) end do end do @@ -1254,7 +1289,7 @@ contains do j = 0, n do i = 0, m dq(i, j, k) = q(i, j, k)*(dy(j + 1) - dy(j - 1)) + q(i, j + 1, k)*(dy(j) + dy(j - 1)) - q(i, j - 1, & - & k)*(dy(j) + dy(j + 1)) + & k)*(dy(j) + dy(j + 1)) dq(i, j, k) = dq(i, j, k)/((dy(j) + dy(j - 1))*(dy(j) + dy(j + 1))) end do end do @@ -1267,18 +1302,20 @@ contains do j = 0, n do i = 0, m dq(i, j, k) = q(i, j, k)*(dz(k + 1) - dz(k - 1)) + q(i, j, k + 1)*(dz(k) + dz(k - 1)) - q(i, j, & - & k - 1)*(dz(k) + dz(k + 1)) + & k - 1)*(dz(k) + dz(k + 1)) dq(i, j, k) = dq(i, j, k)/((dz(k) + dz(k - 1))*(dz(k) + dz(k + 1))) end do end do end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_gradient_dir !> Subroutine that writes on each time step the changes of the lagrangian bubbles. !! @param qtime Current time impure subroutine s_write_lag_particles(qtime) + real(wp), intent(in) :: qtime integer :: k character(LEN=path_len + 2*name_len) :: file_loc @@ -1298,7 +1335,7 @@ contains if (.not. file_exist) then open (11, FILE=trim(file_loc), form='formatted', position='rewind') write (11, FMT) 'currentTime', 'particleID', 'x', 'y', 'z', 'coreVaporMass', 'coreVaporConcentration', 'radius', & - & 'interfaceVelocity', 'corePressure' + & 'interfaceVelocity', 'corePressure' else open (11, FILE=trim(file_loc), form='formatted', position='append') end if @@ -1312,16 +1349,18 @@ contains ! Cycle through list do k = 1, nBubs write (11, FMT) qtime, lag_id(k, 1), mtn_pos(k, 1, 1), mtn_pos(k, 2, 1), mtn_pos(k, 3, 1), gas_mv(k, 1), gas_mv(k, & - & 1)/(gas_mv(k, 1) + gas_mg(k)), intfc_rad(k, 1), intfc_vel(k, 1), gas_p(k, 1) + & 1)/(gas_mv(k, 1) + gas_mg(k)), intfc_rad(k, 1), intfc_vel(k, 1), gas_p(k, 1) end do close (11) + end subroutine s_write_lag_particles !> Subroutine that writes some useful statistics related to the volume fraction of the particles (void fraction) in the !! computatioational domain on each time step. !! @param qtime Current time impure subroutine s_write_void_evol(qtime) + real(wp), intent(in) :: qtime real(wp) :: volcell, voltot real(wp) :: lag_void_max, lag_void_avg, lag_vol @@ -1336,11 +1375,9 @@ contains inquire (FILE=trim(file_loc), EXIST=file_exist) if (.not. file_exist) then open (12, FILE=trim(file_loc), form='formatted', position='rewind') - ! write (12, *) 'currentTime, averageVoidFraction, ', & - ! 'maximumVoidFraction, totalParticlesVolume' - ! write (12, *) 'The averageVoidFraction value does ', & - ! 'not reflect the real void fraction in the cloud since the ', & - ! 'cells which do not have bubbles are not accounted' + ! write (12, *) 'currentTime, averageVoidFraction, ', & 'maximumVoidFraction, totalParticlesVolume' write (12, *) + ! 'The averageVoidFraction value does ', & 'not reflect the real void fraction in the cloud since the ', & 'cells + ! which do not have bubbles are not accounted' else open (12, FILE=trim(file_loc), form='formatted', position='append') end if @@ -1350,7 +1387,7 @@ contains lag_void_avg = 0._wp lag_vol = 0._wp $:GPU_PARALLEL_LOOP(private='[volcell]', collapse=3, reduction='[[lag_vol, lag_void_avg], [lag_void_max]]', & - & reductionOp='[+, MAX]', copy='[lag_vol, lag_void_avg, lag_void_max]') + & reductionOp='[+, MAX]', copy='[lag_vol, lag_void_avg, lag_void_max]') do k = 0, p do j = 0, n do i = 0, m @@ -1376,19 +1413,21 @@ contains end if #endif voltot = lag_void_avg - ! This voidavg value does not reflect the real void fraction in the cloud - ! since the cell which does not have bubbles are not accounted + ! This voidavg value does not reflect the real void fraction in the cloud since the cell which does not have bubbles are not + ! accounted if (lag_vol > 0._wp) lag_void_avg = lag_void_avg/lag_vol if (proc_rank == 0) then write (12, '(6X,4e24.8)') qtime, lag_void_avg, lag_void_max, voltot close (12) end if + end subroutine s_write_void_evol !> Subroutine that writes the restarting files for the particles in the lagrangian solver. !! @param t_step Current time step impure subroutine s_write_restart_lag_bubbles(t_step) + ! Generic string used to store the address of a particular file integer, intent(in) :: t_step character(LEN=path_len + 2*name_len) :: file_loc @@ -1405,6 +1444,7 @@ contains integer, dimension(2) :: gsizes, lsizes, start_idx_part integer, allocatable :: proc_bubble_counts(:) real(wp), dimension(1:1, 1:lag_io_vars) :: dummy + dummy = 0._wp bub_id = 0._wp @@ -1496,7 +1536,7 @@ contains ! Skip header (written by rank 0) disp = int(sizeof(tot_part) + 2*sizeof(mytime) + sizeof(num_procs) + num_procs*sizeof(proc_bubble_counts(1)), & - & MPI_OFFSET_KIND) + & MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA_lag_bubbles, lag_io_vars*bub_id, mpi_p, status, ierr) @@ -1512,7 +1552,7 @@ contains ! Skip header (written by rank 0) disp = int(sizeof(tot_part) + 2*sizeof(mytime) + sizeof(num_procs) + num_procs*sizeof(proc_bubble_counts(1)), & - & MPI_OFFSET_KIND) + & MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, dummy, 0, mpi_p, status, ierr) @@ -1522,14 +1562,16 @@ contains deallocate (proc_bubble_counts) #endif + end subroutine s_write_restart_lag_bubbles !> This procedure calculates the maximum and minimum radius of each bubble. subroutine s_calculate_lag_bubble_stats() + integer :: k $:GPU_PARALLEL_LOOP(private='[k]', reduction='[[Rmax_glb], [Rmin_glb]]', reductionOp='[MAX, MIN]', & - & copy='[Rmax_glb, Rmin_glb]') + & copy='[Rmax_glb, Rmin_glb]') do k = 1, nBubs Rmax_glb = max(Rmax_glb, intfc_rad(k, 1)/bub_R0(k)) Rmin_glb = min(Rmin_glb, intfc_rad(k, 1)/bub_R0(k)) @@ -1537,10 +1579,12 @@ contains Rmin_stats(k) = min(Rmin_stats(k), intfc_rad(k, 1)/bub_R0(k)) end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_calculate_lag_bubble_stats !> Subroutine that writes the maximum and minimum radius of each bubble. impure subroutine s_write_lag_bubble_stats() + integer :: k character(LEN=path_len + 2*name_len) :: file_loc character(len=20) :: FMT @@ -1567,15 +1611,17 @@ contains do k = 1, nBubs write (13, FMT) proc_rank, lag_id(k, 1), mtn_pos(k, 1, 1), mtn_pos(k, 2, 1), mtn_pos(k, 3, 1), Rmax_stats(k), & - & Rmin_stats(k) + & Rmin_stats(k) end do close (13) + end subroutine s_write_lag_bubble_stats !> The purpose of this subroutine is to remove one specific particle if dt is too small. - !! @param bub_id Particle id + !! @param bub_id Particle id impure subroutine s_remove_lag_bubble(bub_id) + integer, intent(in) :: bub_id integer :: i @@ -1605,10 +1651,12 @@ contains nBubs = nBubs - 1 $:GPU_UPDATE(device='[nBubs]') + end subroutine s_remove_lag_bubble !> The purpose of this subroutine is to deallocate variables impure subroutine s_finalize_lagrangian_solver() + integer :: i do i = 1, q_beta_idx @@ -1639,5 +1687,7 @@ contains @:DEALLOCATE(gas_dmvdt) @:DEALLOCATE(mtn_dposdt) @:DEALLOCATE(mtn_dveldt) + end subroutine s_finalize_lagrangian_solver + end module m_bubbles_EL diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index 263b80805b..f7a9aa27c8 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -6,19 +6,22 @@ !> @brief Kernel functions (Gaussian, delta) that smear Lagrangian bubble effects onto the Eulerian grid module m_bubbles_EL_kernels + use m_mpi_proxy !< Message passing interface (MPI) module proxy implicit none + contains !> The purpose of this subroutine is to smear the strength of the lagrangian bubbles into the Eulerian framework using different !! approaches. - !! @param nBubs Number of lagrangian bubbles in the current domain - !! @param lbk_rad Radius of the bubbles - !! @param lbk_vel Interface velocity of the bubbles - !! @param lbk_s Computational coordinates of the bubbles - !! @param lbk_pos Spatial coordinates of the bubbles - !! @param updatedvar Eulerian variable to be updated + !! @param nBubs Number of lagrangian bubbles in the current domain + !! @param lbk_rad Radius of the bubbles + !! @param lbk_vel Interface velocity of the bubbles + !! @param lbk_s Computational coordinates of the bubbles + !! @param lbk_pos Spatial coordinates of the bubbles + !! @param updatedvar Eulerian variable to be updated subroutine s_smoothfunction(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) + integer, intent(in) :: nBubs real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s, lbk_pos real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel @@ -30,11 +33,13 @@ contains case (2) call s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) end select smoothfunc + end subroutine s_smoothfunction !> The purpose of this procedure contains the algorithm to use the delta kernel function to map the effect of the bubbles. The !! effect of the bubbles only affects the cell where the bubble is located. subroutine s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) + integer, intent(in) :: nBubs real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel @@ -72,8 +77,7 @@ contains $:GPU_ATOMIC(atomic='update') updatedvar(2)%sf(cell(1), cell(2), cell(3)) = updatedvar(2)%sf(cell(1), cell(2), cell(3)) + real(addFun2, kind=stp) - ! Product of two smeared functions - ! Update void fraction * time derivative of void fraction + ! Product of two smeared functions Update void fraction * time derivative of void fraction if (lag_params%cluster_type >= 4) then addFun3 = (strength_vol*strength_vel)/Vol $:GPU_ATOMIC(atomic='update') @@ -81,11 +85,13 @@ contains end if end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_deltafunc !> The purpose of this procedure contains the algorithm to use the gaussian kernel function to map the effect of the bubbles. !! The effect of the bubbles affects the 3X3x3 cells that surround the bubble. subroutine s_gaussian(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) + integer, intent(in) :: nBubs real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s, lbk_pos real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel @@ -130,8 +136,8 @@ contains cellaux(3) = cell(3) + k - (mapCells + 1) if (p == 0) cellaux(3) = 0 - ! Check if the cells intended to smear the bubbles in are in the computational domain - ! and redefine the cells for symmetric boundary + ! Check if the cells intended to smear the bubbles in are in the computational domain and redefine the cells + ! for symmetric boundary call s_check_celloutside(cellaux, celloutside) if (.not. celloutside) then @@ -158,31 +164,32 @@ contains addFun1 = func*strength_vol $:GPU_ATOMIC(atomic='update') updatedvar(1)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(1)%sf(cellaux(1), cellaux(2), & - & cellaux(3)) + real(addFun1, kind=stp) + & cellaux(3)) + real(addFun1, kind=stp) ! Update time derivative of void fraction addFun2 = func*strength_vel $:GPU_ATOMIC(atomic='update') updatedvar(2)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(2)%sf(cellaux(1), cellaux(2), & - & cellaux(3)) + real(addFun2, kind=stp) + & cellaux(3)) + real(addFun2, kind=stp) - ! Product of two smeared functions - ! Update void fraction * time derivative of void fraction + ! Product of two smeared functions Update void fraction * time derivative of void fraction if (lag_params%cluster_type >= 4) then addFun3 = func2*strength_vol*strength_vel $:GPU_ATOMIC(atomic='update') updatedvar(5)%sf(cellaux(1), cellaux(2), cellaux(3)) = updatedvar(5)%sf(cellaux(1), cellaux(2), & - & cellaux(3)) + real(addFun3, kind=stp) + & cellaux(3)) + real(addFun3, kind=stp) end if end do end do end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_gaussian !> The purpose of this subroutine is to apply the gaussian kernel function for each bubble (Maeda and Colonius, 2018)). subroutine s_applygaussian(center, cellaux, nodecoord, stddsv, strength_idx, func) + $:GPU_ROUTINE(function_name='s_applygaussian',parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: center @@ -198,11 +205,11 @@ contains distance = sqrt((center(1) - nodecoord(1))**2._wp + (center(2) - nodecoord(2))**2._wp + (center(3) - nodecoord(3))**2._wp) if (num_dims == 3) then - !< 3D gaussian function + !> 3D gaussian function func = exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv)**3._wp else if (cyl_coord) then - !< 2D cylindrical function: + !> 2D cylindrical function: ! We smear particles in the azimuthal direction for given r theta = 0._wp Nr = ceiling(2._wp*pi*nodecoord(2)/(y_cb(cellaux(2)) - y_cb(cellaux(2) - 1))) @@ -220,11 +227,11 @@ contains distance = sqrt((center(1) - nodecoord(1))**2._wp + L2) ! nodecoord(2)*dtheta is the azimuthal width of the cell func = func + dtheta/2._wp/pi*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv) & - & **(3._wp*(strength_idx + 1._wp)) + & **(3._wp*(strength_idx + 1._wp)) end do else - !< 2D cartesian function: + !> 2D cartesian function: ! We smear particles considering a virtual depth (lag_params%charwidth) theta = 0._wp Nr = ceiling(lag_params%charwidth/(y_cb(cellaux(2)) - y_cb(cellaux(2) - 1))) @@ -238,17 +245,19 @@ contains Lz2 = (center(3) - (dzp*(0.5_wp + Nr_count) - lag_params%charwidth/2._wp))**2._wp distance = sqrt((center(1) - nodecoord(1))**2._wp + (center(2) - nodecoord(2))**2._wp + Lz2) func = func + dzp/lag_params%charwidth*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv) & - & **(3._wp*(strength_idx + 1._wp)) + & **(3._wp*(strength_idx + 1._wp)) end do end if end if + end subroutine s_applygaussian !> The purpose of this subroutine is to check if the current cell is outside the computational domain or not (including ghost !! cells). - !! @param cellaux Tested cell to smear the bubble effect in. - !! @param celloutside If true, then cellaux is outside the computational domain. + !! @param cellaux Tested cell to smear the bubble effect in. + !! @param celloutside If true, then cellaux is outside the computational domain. subroutine s_check_celloutside(cellaux, celloutside) + $:GPU_ROUTINE(function_name='s_check_celloutside',parallelism='[seq]', cray_inline=True) integer, dimension(3), intent(inout) :: cellaux @@ -275,12 +284,14 @@ contains celloutside = .true. end if end if + end subroutine s_check_celloutside !> This subroutine relocates the current cell, if it intersects a symmetric boundary. - !! @param cell Cell of the current bubble - !! @param cellaux Cell to map the bubble effect in. + !! @param cell Cell of the current bubble + !! @param cellaux Cell to map the bubble effect in. subroutine s_shift_cell_symmetric_bc(cellaux, cell) + $:GPU_ROUTINE(function_name='s_shift_cell_symmetric_bc', parallelism='[seq]', cray_inline=True) integer, dimension(3), intent(inout) :: cellaux @@ -311,13 +322,15 @@ contains cellaux(3) = cellaux(3) - (2*(cellaux(3) - p) - 1) end if end if + end subroutine s_shift_cell_symmetric_bc !> Calculates the standard deviation of the bubble being smeared in the Eulerian framework. - !! @param cell Cell where the bubble is located - !! @param volpart Volume of the bubble - !! @param stddsv Standard deviaton + !! @param cell Cell where the bubble is located + !! @param volpart Volume of the bubble + !! @param stddsv Standard deviaton subroutine s_compute_stddsv(cell, volpart, stddsv) + $:GPU_ROUTINE(function_name='s_compute_stddsv',parallelism='[seq]', cray_inline=True) integer, dimension(3), intent(in) :: cell @@ -326,11 +339,11 @@ contains real(wp) :: chardist, charvol real(wp) :: rad - !< Compute characteristic distance + !> Compute characteristic distance chardist = sqrt(dx(cell(1))*dy(cell(2))) if (p > 0) chardist = (dx(cell(1))*dy(cell(2))*dz(cell(3)))**(1._wp/3._wp) - !< Compute characteristic volume + !> Compute characteristic volume if (p > 0) then charvol = dx(cell(1))*dy(cell(2))*dz(cell(3)) else @@ -341,21 +354,23 @@ contains end if end if - !< Compute Standard deviaton + !> Compute Standard deviaton if (((volpart/charvol) > 0.5_wp*lag_params%valmaxvoid) .or. (lag_params%smooth_type == 1)) then rad = (3._wp*volpart/(4._wp*pi))**(1._wp/3._wp) stddsv = 1._wp*lag_params%epsilonb*max(chardist, rad) else stddsv = 0._wp end if + end subroutine s_compute_stddsv !> The purpose of this procedure is to calculate the characteristic cell volume - !! @param cellx x-direction cell index - !! @param celly y-direction cell index - !! @param cellz z-direction cell index - !! @param Charvol Characteristic volume + !! @param cellx x-direction cell index + !! @param celly y-direction cell index + !! @param cellz z-direction cell index + !! @param Charvol Characteristic volume subroutine s_get_char_vol(cellx, celly, cellz, Charvol) + $:GPU_ROUTINE(function_name='s_get_char_vol',parallelism='[seq]', cray_inline=True) integer, intent(in) :: cellx, celly, cellz @@ -370,12 +385,14 @@ contains Charvol = dx(cellx)*dy(celly)*lag_params%charwidth end if end if + end subroutine s_get_char_vol - !> This subroutine transforms the computational coordinates of the bubble from real type into integer. - !! @param s_cell Computational coordinates of the bubble, real type - !! @param get_cell Computational coordinates of the bubble, integer type + !> This subroutine transforms the computational coordinates of the bubble from real type into integer. + !! @param s_cell Computational coordinates of the bubble, real type + !! @param get_cell Computational coordinates of the bubble, integer type subroutine s_get_cell(s_cell, get_cell) + $:GPU_ROUTINE(function_name='s_get_cell',parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: s_cell @@ -386,5 +403,7 @@ contains do i = 1, num_dims if (s_cell(i) < 0._wp) get_cell(i) = get_cell(i) - 1 end do + end subroutine s_get_cell + end module m_bubbles_EL_kernels diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 033d9444d1..788c3c1d5d 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -7,8 +7,9 @@ #:include 'macros.fpp' module m_cbc - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion !< State variables type conversion procedures use m_compute_cbc use m_thermochem, only: get_mixture_energy_mass, get_mixture_specific_heat_cv_mass, get_mixture_specific_heat_cp_mass, & @@ -22,28 +23,25 @@ module m_cbc private; public :: s_initialize_cbc_module, s_cbc, s_finalize_cbc_module - !! The cell-average primitive variables. They are obtained by reshaping (RS) - !! q_prim_vf in the coordinate direction normal to the domain boundary along - !! which the CBC is applied. + !! The cell-average primitive variables. They are obtained by reshaping (RS) q_prim_vf in the coordinate direction normal to the + !! domain boundary along which the CBC is applied. real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsx_vf real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsy_vf real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsz_vf $:GPU_DECLARE(create='[q_prim_rsx_vf, q_prim_rsy_vf, q_prim_rsz_vf]') - !! Cell-average fluxes (src - source). These are directly determined from the - !! cell-average primitive variables, q_prims_rs_vf, and not a Riemann solver. + !! Cell-average fluxes (src - source). These are directly determined from the cell-average primitive variables, q_prims_rs_vf, + !! and not a Riemann solver. real(wp), allocatable, dimension(:,:,:,:) :: F_rsx_vf, F_src_rsx_vf real(wp), allocatable, dimension(:,:,:,:) :: F_rsy_vf, F_src_rsy_vf real(wp), allocatable, dimension(:,:,:,:) :: F_rsz_vf, F_src_rsz_vf $:GPU_DECLARE(create='[F_rsx_vf, F_src_rsx_vf, F_rsy_vf, F_src_rsy_vf, F_rsz_vf, F_src_rsz_vf]') - !! There is a CCE bug that is causing some subset of these variables to interfere - !! with variables of the same name in m_riemann_solvers.fpp, and giving this versions - !! unique "_l" names works around the bug. Other private module allocatable arrays - !! in `acc declare create` clauses don't have this problem, so we still need to - !! isolate this bug. + !! There is a CCE bug that is causing some subset of these variables to interfere with variables of the same name in + !! m_riemann_solvers.fpp, and giving this versions unique "_l" names works around the bug. Other private module allocatable + !! arrays in `acc declare create` clauses don't have this problem, so we still need to isolate this bug. real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf_l, flux_src_rsx_vf_l real(wp), allocatable, dimension(:,:,:,:) :: flux_rsy_vf_l, flux_src_rsy_vf_l @@ -58,17 +56,15 @@ module m_cbc !> Finite diff. coefficients z-dir The first dimension identifies the location of a coefficient in the FD formula, while the !! last dimension denotes the location of the CBC. real(wp), allocatable, dimension(:,:) :: fd_coef_z - ! Bug with NVHPC when using nullified pointers in a declare create - ! real(wp), pointer, dimension(:, :) :: fd_coef => null() + ! Bug with NVHPC when using nullified pointers in a declare create real(wp), pointer, dimension(:, :) :: fd_coef => null() real(wp), allocatable, dimension(:,:,:) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir real(wp), allocatable, dimension(:,:,:) :: pi_coef_y !< Polynomial interpolant coefficients in y-dir real(wp), allocatable, dimension(:,:,:) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir $:GPU_DECLARE(create='[ds, fd_coef_x, fd_coef_y, fd_coef_z, pi_coef_x, pi_coef_y, pi_coef_z]') - !! The first dimension of the array identifies the polynomial, the - !! second dimension identifies the position of its coefficients and the last - !! dimension denotes the location of the CBC. + !! The first dimension of the array identifies the polynomial, the second dimension identifies the position of its coefficients + !! and the last dimension denotes the location of the CBC. type(int_bounds_info) :: is1, is2, is3 !< Indical bounds in the s1-, s2- and s3-directions $:GPU_DECLARE(create='[is1, is2, is3]') @@ -80,9 +76,8 @@ module m_cbc $:GPU_DECLARE(create='[dj, bcxb, bcxe, bcyb, bcye, bczb, bcze]') $:GPU_DECLARE(create='[cbc_dir, cbc_loc, flux_cbc_index]') - !! GRCBC inputs for subsonic inflow and outflow conditions consisting of - !! inflow velocities, pressure, density and void fraction as well as - !! outflow velocities and pressure + !! GRCBC inputs for subsonic inflow and outflow conditions consisting of inflow velocities, pressure, density and void fraction + !! as well as outflow velocities and pressure real(wp), allocatable, dimension(:) :: pres_in, pres_out, Del_in, Del_out real(wp), allocatable, dimension(:,:) :: vel_in, vel_out @@ -90,11 +85,13 @@ module m_cbc $:GPU_DECLARE(create='[pres_in, pres_out, Del_in, Del_out]') $:GPU_DECLARE(create='[vel_in, vel_out]') $:GPU_DECLARE(create='[alpha_rho_in, alpha_in]') + contains !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_cbc_module + integer :: i logical :: is_cbc type(int_bounds_info) :: idx1, idx2 @@ -299,8 +296,8 @@ contains $:GPU_UPDATE(device='[fd_coef_x, fd_coef_y, fd_coef_z, pi_coef_x, pi_coef_y, pi_coef_z]') - ! Associating the procedural pointer to the appropriate subroutine - ! that will be utilized in the conversion to the mixture variables + ! Associating the procedural pointer to the appropriate subroutine that will be utilized in the conversion to the mixture + ! variables bcxb = bc_x%beg bcxe = bc_x%end @@ -351,15 +348,16 @@ contains end if #:endfor $:GPU_UPDATE(device='[vel_in, vel_out, pres_in, pres_out, Del_in, Del_out, alpha_rho_in, alpha_in]') + end subroutine s_initialize_cbc_module !> Compute CBC coefficients !! @param cbc_dir_in CBC coordinate direction !! @param cbc_loc_in CBC coordinate location subroutine s_compute_cbc_coefficients(cbc_dir_in, cbc_loc_in) - ! Description: The purpose of this subroutine is to compute the grid - ! dependent FD and PI coefficients, or CBC coefficients, - ! provided the CBC coordinate direction and location. + + ! Description: The purpose of this subroutine is to compute the grid dependent FD and PI coefficients, or CBC coefficients, + ! provided the CBC coordinate direction and location. ! CBC coordinate direction and location integer, intent(in) :: cbc_dir_in, cbc_loc_in @@ -371,6 +369,7 @@ contains integer :: i ! Associating CBC coefficients pointers + call s_associate_cbc_coefficients_pointers(cbc_dir_in, cbc_loc_in) ! Determining the cell-boundary locations in the s-direction @@ -402,32 +401,34 @@ contains fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp fd_coef_${XYZ}$ (0, & - & cbc_loc_in) = -50._wp/(25._wp*ds(0) + 2._wp*ds(1) - 1.e1_wp*ds(2) + 1.e1_wp*ds(3) - 3._wp*ds(4)) + & cbc_loc_in) = -50._wp/(25._wp*ds(0) + 2._wp*ds(1) - 1.e1_wp*ds(2) + 1.e1_wp*ds(3) & + & - 3._wp*ds(4)) fd_coef_${XYZ}$ (1, cbc_loc_in) = -48._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (2, cbc_loc_in) = 36._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (3, cbc_loc_in) = -16._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp fd_coef_${XYZ}$ (4, cbc_loc_in) = 3._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/25._wp pi_coef_${XYZ}$ (0, 0, & - & cbc_loc_in) = ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)))/((s_cb(1) - s_cb(4)) & - & *(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) + & cbc_loc_in) = ((s_cb(0) - s_cb(1))*(s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)))/((s_cb(1) & + & - s_cb(4))*(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(2))) pi_coef_${XYZ}$ (0, 1, & - & cbc_loc_in) = ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(1) - s_cb(3)) & - & - (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + (s_cb(4) - s_cb(1)))))/((s_cb(0) - s_cb(3))*(s_cb(1) & - & - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) + & cbc_loc_in) = ((s_cb(1) - s_cb(0))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(1) & + & - s_cb(3)) - (s_cb(0) - s_cb(4))*((s_cb(3) - s_cb(1)) + (s_cb(4) - s_cb(1)))))/((s_cb(0) & + & - s_cb(3))*(s_cb(1) - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) pi_coef_${XYZ}$ (0, 2, & - & cbc_loc_in) = (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)) + ((s_cb(0) - s_cb(2)) & - & + (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/((s_cb(2) - s_cb(0))*(s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) + & cbc_loc_in) = (s_cb(1) - s_cb(0))*((s_cb(1) - s_cb(2))*(s_cb(1) - s_cb(3)) + ((s_cb(0) & + & - s_cb(2)) + (s_cb(1) - s_cb(3)))*(s_cb(0) - s_cb(4)))/((s_cb(2) - s_cb(0))*(s_cb(0) & + & - s_cb(3))*(s_cb(0) - s_cb(4))) pi_coef_${XYZ}$ (1, 0, & - & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))*(s_cb(2) - s_cb(3)))/((s_cb(2) - s_cb(4)) & - & *(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) + & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(2) - s_cb(1))*(s_cb(2) - s_cb(3)))/((s_cb(2) & + & - s_cb(4))*(s_cb(4) - s_cb(0))*(s_cb(4) - s_cb(1))) pi_coef_${XYZ}$ (1, 1, & - & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(2) - s_cb(3)) & - & + (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + (s_cb(2) - s_cb(4)))))/((s_cb(0) - s_cb(3))*(s_cb(1) & - & - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) + & cbc_loc_in) = ((s_cb(0) - s_cb(2))*(s_cb(1) - s_cb(2))*((s_cb(1) - s_cb(3))*(s_cb(2) & + & - s_cb(3)) + (s_cb(0) - s_cb(4))*((s_cb(1) - s_cb(3)) + (s_cb(2) - s_cb(4)))))/((s_cb(0) & + & - s_cb(3))*(s_cb(1) - s_cb(3))*(s_cb(0) - s_cb(4))*(s_cb(1) - s_cb(4))) pi_coef_${XYZ}$ (1, 2, & - & cbc_loc_in) = ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))*(s_cb(2) - s_cb(4)))/((s_cb(0) - s_cb(2)) & - & *(s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) + & cbc_loc_in) = ((s_cb(1) - s_cb(2))*(s_cb(2) - s_cb(3))*(s_cb(2) - s_cb(4)))/((s_cb(0) & + & - s_cb(2))*(s_cb(0) - s_cb(3))*(s_cb(0) - s_cb(4))) end if end if #:endfor @@ -435,6 +436,7 @@ contains ! END: Computing CBC4 Coefficients ! Nullifying CBC coefficients + end subroutine s_compute_cbc_coefficients !> @brief Associates finite-difference and polynomial-interpolation CBC coefficients with targets based on coordinate direction @@ -443,9 +445,11 @@ contains !! @param cbc_dir_in CBC coordinate direction !! @param cbc_loc_in CBC coordinate location subroutine s_associate_cbc_coefficients_pointers(cbc_dir_in, cbc_loc_in) + integer, intent(in) :: cbc_dir_in, cbc_loc_in integer :: i !< Generic loop iterator ! Associating CBC Coefficients in x-direction + if (cbc_dir_in == 1) then ! fd_coef => fd_coef_x; if (weno_order > 1) pi_coef => pi_coef_x @@ -490,6 +494,7 @@ contains end if $:GPU_UPDATE(device='[ds]') + end subroutine s_associate_cbc_coefficients_pointers !> The following is the implementation of the CBC based on the work of Thompson (1987, 1990) on hyperbolic systems. The CBC is @@ -504,6 +509,7 @@ contains !! @param iy Index bound in the second coordinate direction !! @param iz Index bound in the third coordinate direction subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, cbc_dir_norm, cbc_loc_norm, ix, iy, iz) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf integer, intent(in) :: cbc_dir_norm, cbc_loc_norm @@ -551,8 +557,7 @@ contains real(wp) :: Cv, Cp, e_mix, Mw, R_gas real(wp) :: vel_K_sum, vel_dv_dt_sum integer :: i, j, k, r !< Generic loop iterators - ! Reshaping of inputted data and association of the FD and PI - ! coefficients, or CBC coefficients, respectively, hinging on + ! Reshaping of inputted data and association of the FD and PI coefficients, or CBC coefficients, respectively, hinging on ! selected CBC coordinate direction cbc_dir = cbc_dir_norm @@ -569,14 +574,14 @@ contains ! PI2 of flux_rs_vf and flux_src_rs_vf at j = 1/2 if (weno_order == 3 .or. dummy) then call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, F_rs${XYZ}$_vf, F_src_rs${XYZ}$_vf, is1, is2, & - & is3, idwbuff(2)%beg, idwbuff(3)%beg) + & is3, idwbuff(2)%beg, idwbuff(3)%beg) $:GPU_PARALLEL_LOOP(private='[i, r, k]', collapse=3) do i = 1, flux_cbc_index do r = is3%beg, is3%end do k = is2%beg, is2%end flux_rs${XYZ}$_vf_l(0, k, r, i) = F_rs${XYZ}$_vf(0, k, r, i) + pi_coef_${XYZ}$ (0, 0, & - & cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, i) - F_rs${XYZ}$_vf(0, k, r, i)) + & cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, i) - F_rs${XYZ}$_vf(0, k, r, i)) end do end do end do @@ -587,7 +592,7 @@ contains do r = is3%beg, is3%end do k = is2%beg, is2%end flux_src_rs${XYZ}$_vf_l(0, k, r, i) = F_src_rs${XYZ}$_vf(0, k, r, i) + (F_src_rs${XYZ}$_vf(1, k, & - & r, i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (0, 0, cbc_loc) + & r, i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (0, 0, cbc_loc) end do end do end do @@ -597,7 +602,7 @@ contains ! PI4 of flux_rs_vf and flux_src_rs_vf at j = 1/2, 3/2 if (weno_order == 5 .or. dummy) then call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, F_rs${XYZ}$_vf, F_src_rs${XYZ}$_vf, is1, is2, & - & is3, idwbuff(2)%beg, idwbuff(3)%beg) + & is3, idwbuff(2)%beg, idwbuff(3)%beg) $:GPU_PARALLEL_LOOP(private='[i, j, r, k]', collapse=4) do i = 1, flux_cbc_index @@ -605,10 +610,10 @@ contains do r = is3%beg, is3%end do k = is2%beg, is2%end flux_rs${XYZ}$_vf_l(j, k, r, i) = F_rs${XYZ}$_vf(j, k, r, i) + pi_coef_${XYZ}$ (j, 0, & - & cbc_loc)*(F_rs${XYZ}$_vf(3, k, r, i) - F_rs${XYZ}$_vf(2, k, r, & - & i)) + pi_coef_${XYZ}$ (j, 1, cbc_loc)*(F_rs${XYZ}$_vf(2, k, r, i) - F_rs${XYZ}$_vf(1, & - & k, r, i)) + pi_coef_${XYZ}$ (j, 2, cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, & - & i) - F_rs${XYZ}$_vf(0, k, r, i)) + & cbc_loc)*(F_rs${XYZ}$_vf(3, k, r, i) - F_rs${XYZ}$_vf(2, k, r, & + & i)) + pi_coef_${XYZ}$ (j, 1, cbc_loc)*(F_rs${XYZ}$_vf(2, k, r, & + & i) - F_rs${XYZ}$_vf(1, k, r, i)) + pi_coef_${XYZ}$ (j, 2, & + & cbc_loc)*(F_rs${XYZ}$_vf(1, k, r, i) - F_rs${XYZ}$_vf(0, k, r, i)) end do end do end do @@ -621,10 +626,11 @@ contains do r = is3%beg, is3%end do k = is2%beg, is2%end flux_src_rs${XYZ}$_vf_l(j, k, r, i) = F_src_rs${XYZ}$_vf(j, k, r, i) + (F_src_rs${XYZ}$_vf(3, & - & k, r, i) - F_src_rs${XYZ}$_vf(2, k, r, i))*pi_coef_${XYZ}$ (j, 0, & - & cbc_loc) + (F_src_rs${XYZ}$_vf(2, k, r, i) - F_src_rs${XYZ}$_vf(1, k, r, & - & i))*pi_coef_${XYZ}$ (j, 1, cbc_loc) + (F_src_rs${XYZ}$_vf(1, k, r, & - & i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (j, 2, cbc_loc) + & k, r, i) - F_src_rs${XYZ}$_vf(2, k, r, i))*pi_coef_${XYZ}$ (j, 0, & + & cbc_loc) + (F_src_rs${XYZ}$_vf(2, k, r, i) - F_src_rs${XYZ}$_vf(1, & + & k, r, i))*pi_coef_${XYZ}$ (j, 1, cbc_loc) + (F_src_rs${XYZ}$_vf(1, & + & k, r, i) - F_src_rs${XYZ}$_vf(0, k, r, i))*pi_coef_${XYZ}$ (j, 2, & + & cbc_loc) end do end do end do @@ -634,9 +640,11 @@ contains ! FD2 or FD4 of RHS at j = 0 $:GPU_PARALLEL_LOOP(collapse=2, private='[r, k, alpha_rho, vel, adv_local, mf, dvel_ds, dadv_ds, Re_cbc, & - & dalpha_rho_ds, dpres_ds, dvel_dt, dadv_dt, dalpha_rho_dt, L, lambda, Ys, dYs_dt, dYs_ds, h_k, Cp_i, Gamma_i, & - & Xs, drho_dt, dpres_dt, dpi_inf_dt, dqv_dt, dgamma_dt, rho, pres, E, H, gamma, pi_inf, qv, c, Ma, T, & - & sum_Enthalpies, Cv, Cp, e_mix, Mw, R_gas, vel_K_sum, vel_dv_dt_sum, i, j]', copyin='[dir_idx]') + & dalpha_rho_ds, dpres_ds, dvel_dt, dadv_dt, dalpha_rho_dt, L, lambda, Ys, dYs_dt, dYs_ds, & + & h_k, & + & Cp_i, Gamma_i, Xs, drho_dt, dpres_dt, dpi_inf_dt, dqv_dt, dgamma_dt, rho, pres, E, H, gamma, & + & pi_inf, qv, c, Ma, T, sum_Enthalpies, Cv, Cp, e_mix, Mw, R_gas, vel_K_sum, vel_dv_dt_sum, i, & + & j]', copyin='[dir_idx]') do r = is3%beg, is3%end do k = is2%beg, is2%end ! Transferring the Primitive Variables @@ -748,7 +756,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_species dYs_ds(i) = q_prim_rs${XYZ}$_vf(j, k, r, chemxb - 1 + i)*fd_coef_${XYZ}$ (j, & - & cbc_loc) + dYs_ds(i) + & cbc_loc) + dYs_ds(i) end do end if end do @@ -764,18 +772,18 @@ contains & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SLIP_WALL)) then call s_compute_slip_wall_L(lambda, L, rho, c, dpres_ds, dvel_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_BUFFER) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_BUFFER)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_BUFFER)) then call s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds, dYs_ds) + & dvel_ds, dadv_ds, dYs_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_INFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_INFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_INFLOW)) then call s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, dpres_ds, dvel_ds) ! Add GRCBC for Subsonic Inflow if (bc_${XYZ}$%grcbc_in) then $:GPU_LOOP(parallelism='[seq]') do i = 2, momxb L(i) = c**3._wp*Ma*(alpha_rho(i - 1) - alpha_rho_in(i - 1, & - & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) - c*Ma*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) + & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) - c*Ma*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) end do if (n > 0) then L(momxb + 1) = c*Ma*(vel(dir_idx(2)) - vel_in(${CBC_DIR}$, dir_idx(2)))/Del_in(${CBC_DIR}$) @@ -786,16 +794,15 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = E_idx, advxe - 1 L(i) = c*Ma*(adv_local(i + 1 - E_idx) - alpha_in(i + 1 - E_idx, & - & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) + & ${CBC_DIR}$))/Del_in(${CBC_DIR}$) end do L(advxe) = rho*c**2._wp*(1._wp + Ma)*(vel(dir_idx(1)) + vel_in(${CBC_DIR}$, dir_idx(1))*sign(1, & - & cbc_loc))/Del_in(${CBC_DIR}$) + c*(1._wp + Ma)*(pres - pres_in(${CBC_DIR}$)) & - & /Del_in(${CBC_DIR}$) + & cbc_loc))/Del_in(${CBC_DIR}$) + c*(1._wp + Ma)*(pres - pres_in(${CBC_DIR}$))/Del_in(${CBC_DIR}$) end if else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_OUTFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_OUTFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_OUTFLOW)) then call s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds, dYs_ds) + & dvel_ds, dadv_ds, dYs_ds) ! Add GRCBC for Subsonic Outflow (Pressure) if (bc_${XYZ}$%grcbc_out) then L(advxe) = c*(1._wp - Ma)*(pres - pres_out(${CBC_DIR}$))/Del_out(${CBC_DIR}$) @@ -803,24 +810,24 @@ contains ! Add GRCBC for Subsonic Outflow (Normal Velocity) if (bc_${XYZ}$%grcbc_vel_out) then L(advxe) = L(advxe) + rho*c**2._wp*(1._wp - Ma)*(vel(dir_idx(1)) + vel_out(${CBC_DIR}$, & - & dir_idx(1))*sign(1, cbc_loc))/Del_out(${CBC_DIR}$) + & dir_idx(1))*sign(1, cbc_loc))/Del_out(${CBC_DIR}$) end if end if else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_FF_SUB_OUTFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_FF_SUB_OUTFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_FF_SUB_OUTFLOW)) then call s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, & - & dadv_ds) + & dadv_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_CP_SUB_OUTFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_CP_SUB_OUTFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_CP_SUB_OUTFLOW)) then call s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds) + & dvel_ds, dadv_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_INFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_INFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_INFLOW)) then call s_compute_supersonic_inflow_L(L) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_OUTFLOW) & - & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_OUTFLOW)) then + & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_OUTFLOW)) then call s_compute_supersonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, & - & dYs_ds) + & dYs_ds) end if ! Be careful about the cylindrical coordinate! @@ -838,7 +845,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims dvel_dt(dir_idx(i)) = dir_flg(dir_idx(i))*(L(1) - L(advxe))/(2._wp*rho*c) + (dir_flg(dir_idx(i)) & - & - 1._wp)*L(momxb + i - 1) + & - 1._wp)*L(momxb + i - 1) end do vel_dv_dt_sum = 0._wp @@ -894,7 +901,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, momxe flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, & - & i) + ds(0)*(vel(i - contxe)*drho_dt + rho*dvel_dt(i - contxe)) + & i) + ds(0)*(vel(i - contxe)*drho_dt + rho*dvel_dt(i - contxe)) end do if (chemistry) then @@ -907,23 +914,24 @@ contains #:if USING_AMD h_k(i) = h_k(i)*gas_constant/molecular_weights_nonparameter(i)*T sum_Enthalpies = sum_Enthalpies + (rho*h_k(i) - pres*Mw/molecular_weights_nonparameter(i) & - & *Cp/R_gas)*dYs_dt(i) + & *Cp/R_gas)*dYs_dt(i) #:else h_k(i) = h_k(i)*gas_constant/molecular_weights(i)*T sum_Enthalpies = sum_Enthalpies + (rho*h_k(i) - pres*Mw/molecular_weights(i)*Cp/R_gas)*dYs_dt(i) #:endif end do flux_rs${XYZ}$_vf_l(-1, k, r, E_idx) = flux_rs${XYZ}$_vf_l(0, k, r, & - & E_idx) + ds(0)*((E/rho + pres/rho)*drho_dt + rho*vel_dv_dt_sum + Cp*T*L(2)/(c*c) + sum_Enthalpies) + & E_idx) + ds(0)*((E/rho + pres/rho)*drho_dt + rho*vel_dv_dt_sum + Cp*T*L(2)/(c*c) & + & + sum_Enthalpies) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_species flux_rs${XYZ}$_vf_l(-1, k, r, i - 1 + chemxb) = flux_rs${XYZ}$_vf_l(0, k, r, & - & chemxb + i - 1) + ds(0)*(drho_dt*Ys(i) + rho*dYs_dt(i)) + & chemxb + i - 1) + ds(0)*(drho_dt*Ys(i) + rho*dYs_dt(i)) end do else flux_rs${XYZ}$_vf_l(-1, k, r, E_idx) = flux_rs${XYZ}$_vf_l(0, k, r, & - & E_idx) + ds(0)*(pres*dgamma_dt + gamma*dpres_dt + dpi_inf_dt + dqv_dt + rho*vel_dv_dt_sum & - & + 5.e-1_wp*drho_dt*vel_K_sum) + & E_idx) + ds(0)*(pres*dgamma_dt + gamma*dpres_dt + dpi_inf_dt + dqv_dt & + & + rho*vel_dv_dt_sum + 5.e-1_wp*drho_dt*vel_K_sum) end if if (riemann_solver == 1) then @@ -935,8 +943,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_src_rs${XYZ}$_vf_l(-1, k, r, i) = 1._wp/max(abs(vel(dir_idx(1))), sgm_eps)*sign(1._wp, & - & vel(dir_idx(1)))*(flux_rs${XYZ}$_vf_l(0, k, r, & - & i) + vel(dir_idx(1))*flux_src_rs${XYZ}$_vf_l(0, k, r, i) + ds(0)*dadv_dt(i - E_idx)) + & vel(dir_idx(1)))*(flux_rs${XYZ}$_vf_l(0, k, r, & + & i) + vel(dir_idx(1))*flux_src_rs${XYZ}$_vf_l(0, k, r, & + & i) + ds(0)*dadv_dt(i - E_idx)) end do else @@ -959,10 +968,10 @@ contains ! END: FD2 or FD4 of RHS at j = 0 - ! The reshaping of outputted data and disssociation of the FD and PI - ! coefficients, or CBC coefficients, respectively, based on selected - ! CBC coordinate direction. + ! The reshaping of outputted data and disssociation of the FD and PI coefficients, or CBC coefficients, respectively, based + ! on selected CBC coordinate direction. call s_finalize_cbc(flux_vf, flux_src_vf) + end subroutine s_cbc !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other @@ -974,6 +983,7 @@ contains !! @param iy Index bound in the second coordinate direction !! @param iz Index bound in the third coordinate direction subroutine s_initialize_cbc(q_prim_vf, flux_vf, flux_src_vf, ix, iy, iz) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(in) :: flux_vf, flux_src_vf type(int_bounds_info), intent(in) :: ix, iy, iz @@ -1063,7 +1073,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_rsx_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1091,7 +1101,7 @@ contains do k = is2%beg, is2%end do j = 0, buff_size q_prim_rsy_vf(j, k, r, momxb + 1) = q_prim_vf(momxb + 1)%sf(k, dj*(n - 2*j) + j, r)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1137,7 +1147,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_rsy_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1211,7 +1221,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_rsz_vf_l(j, k, r, advxb) = flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1220,17 +1230,20 @@ contains end if ! END: Reshaping Inputted Data in z-direction - ! Association of the procedural pointer to the appropriate procedure - ! that will be utilized in the evaluation of L variables for the CBC + ! Association of the procedural pointer to the appropriate procedure that will be utilized in the evaluation of L variables + ! for the CBC + end subroutine s_initialize_cbc - !> Deallocation and/or the disassociation procedures that are necessary in order to finalize the CBC application + !> Deallocation and/or the disassociation procedures that are necessary in order to finalize the CBC application !! @param flux_vf Cell-boundary-average fluxes !! @param flux_src_vf Cell-boundary-average flux sources subroutine s_finalize_cbc(flux_vf, flux_src_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf integer :: i, j, k, r !< Generic loop iterators ! Determining the indicial shift based on CBC location + dj = max(0, cbc_loc) $:GPU_UPDATE(device='[dj]') @@ -1275,7 +1288,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(dj*((m - 1) - 2*j) + j, k, r) = flux_src_rsx_vf_l(j, k, r, advxb)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1325,7 +1338,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(k, dj*((n - 1) - 2*j) + j, r) = flux_src_rsy_vf_l(j, k, r, advxb)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1377,7 +1390,7 @@ contains do k = is2%beg, is2%end do j = -1, buff_size flux_src_vf(advxb)%sf(r, k, dj*((p - 1) - 2*j) + j) = flux_src_rsz_vf_l(j, k, r, advxb)*sign(1._wp, & - & -1._wp*cbc_loc) + & -1._wp*cbc_loc) end do end do end do @@ -1385,10 +1398,12 @@ contains end if end if ! END: Reshaping Outputted Data in z-direction + end subroutine s_finalize_cbc !> @brief Detects whether any domain boundary uses characteristic boundary conditions. elemental subroutine s_any_cbc_boundaries(toggle) + logical, intent(inout) :: toggle toggle = .false. @@ -1398,10 +1413,12 @@ contains toggle = .true. end if #:endfor + end subroutine s_any_cbc_boundaries !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_cbc_module + logical :: is_cbc call s_any_cbc_boundaries(is_cbc) @@ -1466,5 +1483,7 @@ contains end if end if end if + end subroutine s_finalize_cbc_module + end module m_cbc diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 1de553cad6..2972aeea4e 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -7,17 +7,20 @@ !> @brief Validates simulation input parameters for consistency and supported configurations module m_checker + use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_helper - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers implicit none private; public :: s_check_inputs + contains !> Checks compatibility of parameters in the input file. Used by the simulation stage impure subroutine s_check_inputs + call s_check_inputs_compilers if (igr) then @@ -33,56 +36,70 @@ contains call s_check_inputs_time_stepping @:PROHIBIT(ib_state_wrt .and. .not. ib, "ib_state_wrt requires ib to be enabled") + end subroutine s_check_inputs !> Checks constraints on compiler options impure subroutine s_check_inputs_compilers + #if !defined(MFC_OpenACC) && !(defined(__PGI) || defined(_CRAYFTN)) @:PROHIBIT(rdma_mpi, "Unsupported value of rdma_mpi for the current compiler") #endif + end subroutine s_check_inputs_compilers !> Checks constraints on WENO scheme parameters impure subroutine s_check_inputs_weno + character(len=5) :: numStr !< for int to string conversion + call s_int_to_str(num_stcls_min*weno_order, numStr) @:PROHIBIT(m + 1 < num_stcls_min*weno_order, & - & "m must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " // trim(numStr)) + & "m must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " // trim(numStr)) @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*weno_order, & - & "For 2D simulation, n must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " & - & // trim(numStr)) + & "For 2D simulation, n must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " & + & // trim(numStr)) @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*weno_order, & - & "For 3D simulation, p must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " & - & // trim(numStr)) + & "For 3D simulation, p must be greater than or equal to (num_stcls_min*weno_order - 1), whose value is " & + & // trim(numStr)) + end subroutine s_check_inputs_weno !> @brief Validates that the grid resolution is sufficient for the MUSCL reconstruction order. impure subroutine s_check_inputs_muscl + character(len=5) :: numStr !< for int to string conversion + call s_int_to_str(num_stcls_min*muscl_order, numStr) @:PROHIBIT(m + 1 < num_stcls_min*muscl_order, & - & "m must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " // trim(numStr)) + & "m must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " // trim(numStr)) @:PROHIBIT(n + 1 < min(1, n)*num_stcls_min*muscl_order, & - & "For 2D simulation, n must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " & - & // trim(numStr)) + & "For 2D simulation, n must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " & + & // trim(numStr)) @:PROHIBIT(p + 1 < min(1, p)*num_stcls_min*muscl_order, & - & "For 3D simulation, p must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " & - & // trim(numStr)) + & "For 3D simulation, p must be greater than or equal to (num_stcls_min*muscl_order - 1), whose value is " & + & // trim(numStr)) + end subroutine s_check_inputs_muscl !> Checks constraints on time stepping parameters impure subroutine s_check_inputs_time_stepping + if (.not. cfl_dt) then @:PROHIBIT(dt <= 0) end if + end subroutine s_check_inputs_time_stepping impure subroutine s_check_inputs_nvidia_uvm + #ifdef __NVCOMPILER_GPU_UNIFIED_MEM @:PROHIBIT(nv_uvm_igr_temps_on_gpu > 3 .or. nv_uvm_igr_temps_on_gpu < 0, & - & "nv_uvm_igr_temps_on_gpu must be in the range [0, 3]") + & "nv_uvm_igr_temps_on_gpu must be in the range [0, 3]") @:PROHIBIT(nv_uvm_igr_temps_on_gpu == 3 .and. igr_iter_solver == 2, & - & "nv_uvm_igr_temps_on_gpu must be in the range [0, 2] for igr_iter_solver == 2") + & "nv_uvm_igr_temps_on_gpu must be in the range [0, 2] for igr_iter_solver == 2") #endif + end subroutine s_check_inputs_nvidia_uvm + end module m_checker diff --git a/src/simulation/m_compute_cbc.fpp b/src/simulation/m_compute_cbc.fpp index 665f8929e0..a4b51ecc1d 100644 --- a/src/simulation/m_compute_cbc.fpp +++ b/src/simulation/m_compute_cbc.fpp @@ -6,6 +6,7 @@ !> @brief Characteristic boundary condition (CBC) computations for subsonic inflow, outflow, and slip walls module m_compute_cbc + use m_global_parameters implicit none @@ -13,9 +14,11 @@ module m_compute_cbc & s_compute_nonreflecting_subsonic_inflow_L, s_compute_nonreflecting_subsonic_outflow_L, & & s_compute_force_free_subsonic_outflow_L, s_compute_constant_pressure_subsonic_outflow_L, s_compute_supersonic_inflow_L, & & s_compute_supersonic_outflow_L + contains !> Base L1 calculation function f_base_L1(lambda, rho, c, dpres_ds, dvel_ds) result(L1) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(3), intent(in) :: lambda real(wp), intent(in) :: rho, c, dpres_ds @@ -26,10 +29,12 @@ contains #:endif real(wp) :: L1 L1 = lambda(1)*(dpres_ds - rho*c*dvel_ds(dir_idx(1))) + end function f_base_L1 !> Fill density L variables subroutine s_fill_density_L(L, lambda_factor, lambda2, c, mf, dalpha_rho_ds, dpres_ds) + $:GPU_ROUTINE(parallelism='[seq]') #:if USING_AMD real(wp), dimension(20), intent(inout) :: L @@ -49,10 +54,12 @@ contains do i = 2, momxb L(i) = lambda_factor*lambda2*(c*c*dalpha_rho_ds(i - 1) - mf(i - 1)*dpres_ds) end do + end subroutine s_fill_density_L !> Fill velocity L variables subroutine s_fill_velocity_L(L, lambda_factor, lambda2, dvel_ds) + $:GPU_ROUTINE(parallelism='[seq]') #:if USING_AMD real(wp), dimension(20), intent(inout) :: L @@ -71,10 +78,12 @@ contains do i = momxb + 1, momxe L(i) = lambda_factor*lambda2*dvel_ds(dir_idx(i - contxe)) end do + end subroutine s_fill_velocity_L !> Fill advection L variables subroutine s_fill_advection_L(L, lambda_factor, lambda2, dadv_ds) + $:GPU_ROUTINE(parallelism='[seq]') #:if USING_AMD real(wp), dimension(20), intent(inout) :: L @@ -93,10 +102,12 @@ contains do i = E_idx, advxe - 1 L(i) = lambda_factor*lambda2*dadv_ds(i - momxe) end do + end subroutine s_fill_advection_L !> Fill chemistry L variables subroutine s_fill_chemistry_L(L, lambda_factor, lambda2, dYs_ds) + $:GPU_ROUTINE(parallelism='[seq]') #:if USING_AMD real(wp), dimension(20), intent(inout) :: L @@ -117,10 +128,12 @@ contains do i = chemxb, chemxe L(i) = lambda_factor*lambda2*dYs_ds(i - chemxb + 1) end do + end subroutine s_fill_chemistry_L !> Slip wall CBC (Thompson 1990, pg. 451) subroutine s_compute_slip_wall_L(lambda, L, rho, c, dpres_ds, dvel_ds) + $:GPU_ROUTINE(function_name='s_compute_slip_wall_L',parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda @@ -140,10 +153,12 @@ contains L(1) = f_base_L1(lambda, rho, c, dpres_ds, dvel_ds) L(2:advxe - 1) = 0._wp L(advxe) = L(1) + end subroutine s_compute_slip_wall_L !> Nonreflecting subsonic buffer CBC (Thompson 1987, pg. 13) subroutine s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) + $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_buffer_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda @@ -178,10 +193,12 @@ contains lambda_factor = (5.e-1_wp - 5.e-1_wp*sign(1._wp, lambda(3))) L(advxe) = lambda_factor*lambda(3)*(dpres_ds + rho*c*dvel_ds(dir_idx(1))) + end subroutine s_compute_nonreflecting_subsonic_buffer_L !> Nonreflecting subsonic inflow CBC (Thompson 1990, pg. 455) subroutine s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, dpres_ds, dvel_ds) + $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_inflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda @@ -200,10 +217,12 @@ contains L(1) = f_base_L1(lambda, rho, c, dpres_ds, dvel_ds) L(2:advxe) = 0._wp if (chemistry) L(chemxb:chemxe) = 0._wp + end subroutine s_compute_nonreflecting_subsonic_inflow_L !> Nonreflecting subsonic outflow CBC (Thompson 1990, pg. 454) subroutine s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) + $:GPU_ROUTINE(function_name='s_compute_nonreflecting_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda @@ -232,10 +251,12 @@ contains call s_fill_advection_L(L, 1._wp, lambda(2), dadv_ds) call s_fill_chemistry_L(L, 1._wp, lambda(2), dYs_ds) L(advxe) = 0._wp + end subroutine s_compute_nonreflecting_subsonic_outflow_L !> Force-free subsonic outflow CBC (Thompson 1990, pg. 454) subroutine s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) + $:GPU_ROUTINE(function_name='s_compute_force_free_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda @@ -261,10 +282,12 @@ contains call s_fill_velocity_L(L, 1._wp, lambda(2), dvel_ds) call s_fill_advection_L(L, 1._wp, lambda(2), dadv_ds) L(advxe) = L(1) + 2._wp*rho*c*lambda(2)*dvel_ds(dir_idx(1)) + end subroutine s_compute_force_free_subsonic_outflow_L !> Constant pressure subsonic outflow CBC (Thompson 1990, pg. 455) subroutine s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds) + $:GPU_ROUTINE(function_name='s_compute_constant_pressure_subsonic_outflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda @@ -290,10 +313,12 @@ contains call s_fill_velocity_L(L, 1._wp, lambda(2), dvel_ds) call s_fill_advection_L(L, 1._wp, lambda(2), dadv_ds) L(advxe) = -L(1) + end subroutine s_compute_constant_pressure_subsonic_outflow_L !> Supersonic inflow CBC (Thompson 1990, pg. 453) subroutine s_compute_supersonic_inflow_L(L) + $:GPU_ROUTINE(function_name='s_compute_supersonic_inflow_L', parallelism='[seq]', cray_inline=True) #:if USING_AMD real(wp), dimension(20), intent(inout) :: L @@ -302,10 +327,12 @@ contains #:endif L(1:advxe) = 0._wp if (chemistry) L(chemxb:chemxe) = 0._wp + end subroutine s_compute_supersonic_inflow_L !> Supersonic outflow CBC (Thompson 1990, pg. 453) subroutine s_compute_supersonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, dadv_ds, dYs_ds) + $:GPU_ROUTINE(function_name='s_compute_supersonic_outflow_L', parallelism='[seq]', cray_inline=True) real(wp), dimension(3), intent(in) :: lambda @@ -334,5 +361,7 @@ contains call s_fill_advection_L(L, 1._wp, lambda(2), dadv_ds) call s_fill_chemistry_L(L, 1._wp, lambda(2), dYs_ds) L(advxe) = lambda(3)*(dpres_ds + rho*c*dvel_ds(dir_idx(1))) + end subroutine s_compute_supersonic_outflow_L + end module m_compute_cbc diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index f6cab7fa78..08dbade6e2 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -6,24 +6,28 @@ !> @brief Computes signed-distance level-set fields and surface normals for immersed-boundary patch geometries module m_compute_levelset - use m_ib_patches !< The IB patch parameters - use m_model !< Subroutine(s) related to STL files - use m_derived_types !< Definitions of the derived types + + use m_ib_patches !< The IB patch parameters + use m_model !< Subroutine(s) related to STL files + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_helper_basic !< Functions to compare floating point numbers implicit none private; public :: s_apply_levelset + contains !> @brief Dispatches level-set distance and normal computations for all ghost points based on their patch geometry type. impure subroutine s_apply_levelset(gps, num_gps) + type(ghost_point), dimension(:), intent(inout) :: gps integer, intent(in) :: num_gps integer :: i, patch_id, patch_geometry ! 3D Patch Geometries + if (p > 0) then $:GPU_PARALLEL_LOOP(private='[i, patch_id, patch_geometry]', copy='[gps]', copyin='[patch_ib(1:num_ibs), Np]') do i = 1, num_gps @@ -65,10 +69,12 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_apply_levelset !> @brief Computes the signed distance and outward normal from a ghost point to a circular immersed boundary. subroutine s_circle_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -93,10 +99,12 @@ contains else gp%levelset_norm = dist_vec(:)/dist end if + end subroutine s_circle_levelset !> @brief Computes the signed distance and outward normal from a ghost point to a 2D NACA airfoil surface. subroutine s_airfoil_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -170,11 +178,13 @@ contains else gp%levelset_norm = matmul(rotation, dist_vec(:))/dist ! convert the normal vector back to global grid coordinates end if + end subroutine s_airfoil_levelset !> @brief Computes the signed distance and outward normal from a ghost point to a 3D extruded airfoil surface including spanwise !! end caps. subroutine s_3d_airfoil_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -267,10 +277,12 @@ contains gp%levelset_norm = matmul(rotation, dist_vec(:)/dist_surf) end if end if + end subroutine s_3d_airfoil_levelset !> Subroutine for computing the levelset values at a ghost point belonging to the rectangle IB subroutine s_rectangle_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -333,11 +345,13 @@ contains else gp%levelset_norm = 0._wp end if + end subroutine s_rectangle_levelset !> @brief Computes the signed distance and outward normal from a ghost point to an elliptical immersed boundary via a quadratic !! projection. subroutine s_ellipse_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -369,23 +383,25 @@ contains normal_vector = xy_local normal_vector(2) = normal_vector(2)*(ellipse_coeffs(1)/ellipse_coeffs(2)) & - & **2._wp ! get the normal direction via the coordinate transformation method + & **2._wp ! get the normal direction via the coordinate transformation method normal_vector = normal_vector/sqrt(dot_product(normal_vector, normal_vector)) ! normalize the vector gp%levelset_norm = matmul(rotation, normal_vector) ! save after rotating the vector to the global frame ! use the normal vector to set up the quadratic equation for the levelset, using A, B, and C in indices 1, 2, and 3 quadratic_coeffs(1) = (normal_vector(1)/ellipse_coeffs(1))**2 + (normal_vector(2)/ellipse_coeffs(2))**2 quadratic_coeffs(2) = 2._wp*((xy_local(1)*normal_vector(1)/(ellipse_coeffs(1)**2)) + (xy_local(2)*normal_vector(2) & - & /(ellipse_coeffs(2)**2))) + & /(ellipse_coeffs(2)**2))) quadratic_coeffs(3) = (xy_local(1)/ellipse_coeffs(1))**2._wp + (xy_local(2)/ellipse_coeffs(2))**2._wp - 1._wp ! compute the levelset with the quadratic equation [ -B + sqrt(B^2 - 4AC) ] / 2A gp%levelset = -0.5_wp*(-quadratic_coeffs(2) + sqrt(quadratic_coeffs(2)**2._wp - 4._wp*quadratic_coeffs(1) & - & *quadratic_coeffs(3)))/quadratic_coeffs(1) + & *quadratic_coeffs(3)))/quadratic_coeffs(1) + end subroutine s_ellipse_levelset !> @brief Computes the signed distance and outward normal from a ghost point to the nearest face of a cuboid immersed boundary. subroutine s_cuboid_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -467,10 +483,12 @@ contains end if gp%levelset_norm = matmul(rotation, dist_vec) + end subroutine s_cuboid_levelset !> @brief Computes the signed distance and outward normal from a ghost point to a spherical immersed boundary. subroutine s_sphere_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -501,11 +519,13 @@ contains else gp%levelset_norm = dist_vec(:)/dist end if + end subroutine s_sphere_levelset !> @brief Computes the signed distance and outward normal from a ghost point to a cylindrical immersed boundary surface and end !! caps. subroutine s_cylinder_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -574,11 +594,13 @@ contains xyz_local = xyz_local/max(norm2(xyz_local), sgm_eps) gp%levelset_norm = matmul(rotation, xyz_local) end if + end subroutine s_cylinder_levelset !> The STL patch is a 2/3D geometry that is imported from an STL file. !! @param gp Ghost point to compute levelset for subroutine s_model_levelset(gp) + $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp @@ -634,5 +656,7 @@ contains gp%levelset = -abs(distance) gp%levelset_norm = matmul(rotation, normals(1:3)) end if + end subroutine s_model_levelset + end module m_compute_levelset diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 90a68aa03c..1be0e73f74 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -7,13 +7,14 @@ !> @brief Writes solution data, run-time stability diagnostics (ICFL, VCFL, CCFL, Rc), and probe/center-of-mass files module m_data_output - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures use m_compile_specific use m_helper - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_sim_helpers use m_delay_file_access use m_ibm @@ -39,7 +40,7 @@ module m_data_output real(wp) :: icfl_max_loc, icfl_max_glb !< ICFL stability extrema on local and global grids real(wp) :: vcfl_max_loc, vcfl_max_glb !< VCFL stability extrema on local and global grids real(wp) :: ccfl_max_loc, ccfl_max_glb !< CCFL stability extrema on local and global grids - real(wp) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids + real(wp) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids $:GPU_DECLARE(create='[icfl_max_loc, icfl_max_glb, vcfl_max_loc, vcfl_max_glb]') $:GPU_DECLARE(create='[ccfl_max_loc, ccfl_max_glb, Rc_min_loc, Rc_min_glb]') @@ -52,16 +53,18 @@ module m_data_output !> @} type(scalar_field), allocatable, dimension(:) :: q_cons_temp_ds + contains !> Write data files. Dispatch subroutine that replaces procedure pointer. - !! @param q_cons_vf Conservative variables - !! @param q_T_sf Temperature scalar field - !! @param q_prim_vf Primitive variables - !! @param t_step Current time step - !! @param bc_type Boundary condition type - !! @param beta Eulerian void fraction from lagrangian bubbles + !! @param q_cons_vf Conservative variables + !! @param q_T_sf Temperature scalar field + !! @param q_prim_vf Primitive variables + !! @param t_step Current time step + !! @param bc_type Boundary condition type + !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_write_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -74,16 +77,19 @@ contains else call s_write_parallel_data_files(q_cons_vf, t_step, bc_type, beta) end if + end subroutine s_write_data_files !> The purpose of this subroutine is to open a new or pre- existing run-time information file and append to it the basic header !! information relevant to current simulation. In general, this requires generating a table header for those stability criteria !! which will be written at every time-step. impure subroutine s_open_run_time_information_file + character(LEN=name_len), parameter :: file_name = 'run_time.inf' !< Name of the run-time information file character(LEN=path_len + name_len) :: file_path !< Relative path to a file in the case directory character(LEN=8) :: file_date !< Creation date of the run-time information file ! Opening the run-time information file + file_path = trim(case_dir) // '/' // trim(file_name) open (3, FILE=trim(file_path), form='formatted', STATUS='replace') @@ -109,35 +115,39 @@ contains end if write (3, *) ! new line + end subroutine s_open_run_time_information_file - !> This opens a formatted data file where the root processor can write out the CoM information + !> This opens a formatted data file where the root processor can write out the CoM information impure subroutine s_open_com_files() + character(len=path_len + 3*name_len) :: file_path !< Relative path to the CoM file in the case directory integer :: i !< Generic loop iterator + do i = 1, num_fluids ! Generating the relative path to the CoM data file write (file_path, '(A,I0,A)') '/fluid', i, '_com.dat' file_path = trim(case_dir) // trim(file_path) - ! Creating the formatted data file and setting up its - ! structure + ! Creating the formatted data file and setting up its structure open (i + 120, file=trim(file_path), form='formatted', position='append', status='unknown') if (n == 0) then write (i + 120, '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' Total Volume ' else if (p == 0) then write (i + 120, & - & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' & - & // ' Total Volume ' + & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' & + & // ' Total Volume ' else write (i + 120, & - & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' // ' z-loc ' & - & // ' Total Volume ' + & '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' y-loc ' // ' z-loc ' & + & // ' Total Volume ' end if end do + end subroutine s_open_com_files - !> This opens a formatted data file where the root processor can write out flow probe information + !> This opens a formatted data file where the root processor can write out flow probe information impure subroutine s_open_probe_files + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the probe data file in the case directory integer :: i !< Generic loop iterator logical :: file_exist @@ -147,8 +157,7 @@ contains write (file_path, '(A,I0,A)') '/D/probe', i, '_prim.dat' file_path = trim(case_dir) // trim(file_path) - ! Creating the formatted data file and setting up its - ! structure + ! Creating the formatted data file and setting up its structure inquire (file=trim(file_path), exist=file_exist) if (file_exist) then @@ -166,9 +175,11 @@ contains open (i + 70, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') end do end if + end subroutine s_open_probe_files impure subroutine s_open_ib_state_file + character(len=path_len + 2*name_len) :: file_loc integer :: ios @@ -176,6 +187,7 @@ contains file_loc = trim(case_dir) // '/D/' // trim(file_loc) open (newunit=ib_state_unit, file=trim(file_loc), form='unformatted', access='stream', status='replace', iostat=ios) if (ios /= 0) call s_mpi_abort('Cannot open IB state output file: ' // trim(file_loc)) + end subroutine s_open_ib_state_file !> The goal of the procedure is to output to the run-time information file the stability criteria extrema in the entire @@ -184,6 +196,7 @@ contains !! @param q_prim_vf Cell-average primitive variables !! @param t_step Current time step impure subroutine s_write_run_time_information(q_prim_vf, t_step) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf integer, intent(in) :: t_step real(wp) :: rho !< Cell-avg. density @@ -205,6 +218,7 @@ contains integer :: j, k, l ! Computing Stability Criteria at Current Time-step + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, vel, alpha, Re, rho, vel_sum, pres, gamma, pi_inf, c, H, qv]') do l = 0, p do k = 0, n @@ -255,7 +269,7 @@ contains ! Determining global stability criteria extrema at current time-step if (num_procs > 1) then call s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & - & Rc_min_glb) + & Rc_min_glb) else icfl_max_glb = icfl_max_loc if (viscous) vcfl_max_glb = vcfl_max_loc @@ -298,9 +312,10 @@ contains end if call s_mpi_barrier() + end subroutine s_write_run_time_information - !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. + !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. !! @param q_cons_vf Cell-average conservative variables !! @param q_T_sf Temperature scalar field !! @param q_prim_vf Cell-average primitive variables @@ -308,19 +323,21 @@ contains !! @param bc_type Boundary condition type !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_write_serial_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - type(scalar_field), intent(inout) :: q_T_sf - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: t_step - type(scalar_field), intent(inout), optional :: beta + + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + integer, intent(in) :: t_step + type(scalar_field), intent(inout), optional :: beta type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type - character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the current time-step directory - character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files - logical :: file_exist !< Logical used to check existence of current time-step directory - character(LEN=15) :: FMT - integer :: i, j, k, l, r - real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params + character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the current time-step directory + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files + logical :: file_exist !< Logical used to check existence of current time-step directory + character(LEN=15) :: FMT + integer :: i, j, k, l, r + real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params ! Creating or overwriting the time-step root directory + write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all' ! Creating or overwriting the current time-step directory @@ -361,8 +378,8 @@ contains write (2) q_cons_vf(i)%sf(0:m, 0:n, 0:p); close (2) end do - ! Lagrangian beta (void fraction) written as q_cons_vf(sys_size+1) to - ! match the parallel I/O path and allow post_process to read it. + ! Lagrangian beta (void fraction) written as q_cons_vf(sys_size+1) to match the parallel I/O path and allow post_process to + ! read it. if (bubbles_lagrange) then write (file_path, '(A,I0,A)') trim(t_step_dir) // '/q_cons_vf', sys_size + 1, '.dat' @@ -398,9 +415,7 @@ contains call s_write_serial_ib_data(t_step) ! write (file_path, '(A,I0,A)') trim(t_step_dir)//'/ib.dat' - ! open (2, FILE=trim(file_path), & - ! FORM='unformatted', & - ! STATUS='new') + ! open (2, FILE=trim(file_path), & FORM='unformatted', & STATUS='new') ! write (2) ib_markers%sf(0:m, 0:n, 0:p); close (2) end if @@ -468,7 +483,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -480,7 +495,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -528,7 +543,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -542,7 +557,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -619,7 +634,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/pres.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -635,7 +650,7 @@ contains do i = 1, nb do r = 1, nnode write (file_path, '(A,I0,A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/mv.', i, '.', r, '.', proc_rank, & - & '.', t_step, '.dat' + & '.', t_step, '.dat' open (2, FILE=trim(file_path)) do j = 0, m @@ -674,14 +689,16 @@ contains end do end if end if + end subroutine s_write_serial_data_files - !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. + !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. !! @param q_cons_vf Cell-average conservative variables !! @param t_step Current time-step !! @param bc_type Boundary condition type !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_write_parallel_data_files(q_cons_vf, t_step, bc_type, beta) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf integer, intent(in) :: t_step type(scalar_field), intent(inout), optional :: beta @@ -890,31 +907,30 @@ contains ! Write ib data if (ib) then call s_write_parallel_ib_data(t_step) - ! write (file_loc, '(A)') 'ib.dat' - ! file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) - ! call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & - ! mpi_info_int, ifile, ierr) - - ! var_MOK = int(sys_size + 1, MPI_OFFSET_KIND) - ! disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1 + int(t_step/t_step_save)) - - ! call MPI_FILE_SET_VIEW(ifile, disp, MPI_INTEGER, MPI_IO_IB_DATA%view, & - ! 'native', mpi_info_int, ierr) - ! call MPI_FILE_WRITE_ALL(ifile, MPI_IO_IB_DATA%var%sf, data_size, & - ! MPI_INTEGER, status, ierr) - ! call MPI_FILE_CLOSE(ifile, ierr) + ! write (file_loc, '(A)') 'ib.dat' file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) call + ! MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & mpi_info_int, ifile, ierr) + + ! var_MOK = int(sys_size + 1, MPI_OFFSET_KIND) disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1 + + ! int(t_step/t_step_save)) + + ! call MPI_FILE_SET_VIEW(ifile, disp, MPI_INTEGER, MPI_IO_IB_DATA%view, & 'native', mpi_info_int, ierr) call + ! MPI_FILE_WRITE_ALL(ifile, MPI_IO_IB_DATA%var%sf, data_size, & MPI_INTEGER, status, ierr) call + ! MPI_FILE_CLOSE(ifile, ierr) end if end if #endif + end subroutine s_write_parallel_data_files !> @brief Writes immersed boundary marker data to a serial (per-processor) unformatted file. subroutine s_write_serial_ib_data(time_step) + integer, intent(in) :: time_step character(LEN=path_len + 2*name_len) :: file_path character(LEN=path_len + 2*name_len) :: t_step_dir ! Creating or overwriting the time-step root directory + write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all' write (t_step_dir, '(a,i0,a,i0)') trim(case_dir) // '/p_all/p', proc_rank, '/', time_step write (file_path, '(A,I0,A)') trim(t_step_dir) // '/ib_data.dat' @@ -923,10 +939,12 @@ contains $:GPU_UPDATE(host='[ib_markers%sf]') write (2) ib_markers%sf(0:m, 0:n, 0:p); close (2) + end subroutine s_write_serial_ib_data !> @brief Writes immersed boundary marker data in parallel using MPI I/O. subroutine s_write_parallel_ib_data(time_step) + integer, intent(in) :: time_step #ifdef MFC_MPI @@ -960,10 +978,12 @@ contains call MPI_FILE_WRITE_ALL(ifile, MPI_IO_IB_DATA%var%sf, data_size, MPI_INTEGER, status, ierr) call MPI_FILE_CLOSE(ifile, ierr) #endif + end subroutine s_write_parallel_ib_data !> @brief Dispatches immersed boundary data output to the serial or parallel writer. subroutine s_write_ib_data_file(time_step) + integer, intent(in) :: time_step if (parallel_io) then @@ -971,27 +991,32 @@ contains else call s_write_serial_ib_data(time_step) end if + end subroutine s_write_ib_data_file !> @brief Writes IB state records to D/ib_state.dat. Must be called only on rank 0. impure subroutine s_write_ib_state_file() + integer :: i do i = 1, num_ibs write (ib_state_unit) mytime, i, patch_ib(i)%force, patch_ib(i)%torque, patch_ib(i)%vel, patch_ib(i)%angular_vel, & - & patch_ib(i)%angles, patch_ib(i)%x_centroid, patch_ib(i)%y_centroid, patch_ib(i)%z_centroid + & patch_ib(i)%angles, patch_ib(i)%x_centroid, patch_ib(i)%y_centroid, patch_ib(i)%z_centroid end do + end subroutine s_write_ib_state_file - !> This writes a formatted data file where the root processor can write out the CoM information + !> This writes a formatted data file where the root processor can write out the CoM information !! @param t_step Current time-step !! @param c_mass_in Center of mass information impure subroutine s_write_com_files(t_step, c_mass_in) + integer, intent(in) :: t_step real(wp), dimension(num_fluids, 5), intent(in) :: c_mass_in integer :: i !< Generic loop iterator real(wp) :: nondim_time !< Non-dimensional time ! Non-dimensional time calculation + if (t_step_old /= dflt_int) then nondim_time = real(t_step + t_step_old, wp)*dt else @@ -1010,10 +1035,11 @@ contains else ! 3D simulation do i = 1, num_fluids ! Loop through fluids write (i + 120, '(6X,6F24.12)') nondim_time, c_mass_in(i, 1), c_mass_in(i, 2), c_mass_in(i, 3), c_mass_in(i, & - & 4), c_mass_in(i, 5) + & 4), c_mass_in(i, 5) end do end if end if + end subroutine s_write_com_files !> This writes a formatted data file for the flow probe information @@ -1021,6 +1047,7 @@ contains !! @param q_cons_vf Conservative variables !! @param accel_mag Acceleration magnitude information impure subroutine s_write_probe_files(t_step, q_cons_vf, accel_mag) + integer, intent(in) :: t_step type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf real(wp), dimension(0:m, 0:n, 0:p), intent(in) :: accel_mag @@ -1028,9 +1055,8 @@ contains real(wp), dimension(-1:n) :: disty real(wp), dimension(-1:p) :: distz - ! The cell-averaged partial densities, density, velocity, pressure, - ! volume fractions, specific heat ratio function, liquid stiffness - ! function, and sound speed. + ! The cell-averaged partial densities, density, velocity, pressure, volume fractions, specific heat ratio function, liquid + ! stiffness function, and sound speed. real(wp) :: lit_gamma, nbub real(wp) :: rho real(wp), dimension(num_vels) :: vel @@ -1105,8 +1131,7 @@ contains end do damage_state = 0._wp - ! Find probe location in terms of indices on a - ! specific processor + ! Find probe location in terms of indices on a specific processor if (n == 0) then ! 1D simulation if ((probe(i)%x >= x_cb(-1)) .and. (probe(i)%x <= x_cb(m))) then do s = -1, m @@ -1127,7 +1152,7 @@ contains ! Computing/Sharing necessary state variables if (elasticity) then call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, rho, gamma, pi_inf, qv, Re, G_local, & - & fluid_pp(:)%G) + & fluid_pp(:)%G) else call s_convert_to_mixture_variables(q_cons_vf, j - 2, k, l, rho, gamma, pi_inf, qv) end if @@ -1144,11 +1169,11 @@ contains end if call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k, l), q_cons_vf(alf_idx)%sf(j - 2, k, l), dyn_p, pi_inf, & - & gamma, rho, qv, rhoYks(:), pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, k, l), & - & q_cons_vf(mom_idx%beg)%sf(j - 2, k, l), G_local) + & gamma, rho, qv, rhoYks(:), pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, k, l), & + & q_cons_vf(mom_idx%beg)%sf(j - 2, k, l), G_local) else call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k, l), q_cons_vf(alf_idx)%sf(j - 2, k, l), dyn_p, & - & pi_inf, gamma, rho, qv, rhoYks, pres, T) + & pi_inf, gamma, rho, qv, rhoYks, pres, T) end if if (model_eqns == 4) then @@ -1206,7 +1231,7 @@ contains ! Compute mixture sound Speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, 0._wp, & - & 0._wp, c, qv) + & 0._wp, c, qv) accel = accel_mag(j - 2, k, l) end if @@ -1235,7 +1260,7 @@ contains ! Computing/Sharing necessary state variables call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l, rho, gamma, pi_inf, qv, Re, G_local, & - & fluid_pp(:)%G) + & fluid_pp(:)%G) do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k - 2, l)/rho end do @@ -1249,11 +1274,12 @@ contains end if call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k - 2, l), q_cons_vf(alf_idx)%sf(j - 2, k - 2, l), & - & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l), & - & q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l), G_local) + & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, & + & q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l), & + & q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l), G_local) else call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l), q_cons_vf(alf_idx)%sf(j - 2, k - 2, l), & - & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) + & dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) end if if (model_eqns == 4) then @@ -1287,7 +1313,7 @@ contains end if ! Compute mixture sound speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, & - & 0._wp, 0._wp, c, qv) + & 0._wp, 0._wp, c, qv) end if end if else ! 3D @@ -1315,7 +1341,7 @@ contains ! Computing/Sharing necessary state variables call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l - 2, rho, gamma, pi_inf, qv, Re, & - & G_local, fluid_pp(:)%G) + & G_local, fluid_pp(:)%G) do s = 1, num_vels vel(s) = q_cons_vf(cont_idx%end + s)%sf(j - 2, k - 2, l - 2)/rho end do @@ -1335,16 +1361,17 @@ contains end if call s_compute_pressure(q_cons_vf(1)%sf(j - 2, k - 2, l - 2), q_cons_vf(alf_idx)%sf(j - 2, k - 2, & - & l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, q_cons_vf(stress_idx%beg)%sf(j - 2, & - & k - 2, l - 2), q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l - 2), G_local) + & l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, & + & q_cons_vf(stress_idx%beg)%sf(j - 2, k - 2, l - 2), & + & q_cons_vf(mom_idx%beg)%sf(j - 2, k - 2, l - 2), G_local) else call s_compute_pressure(q_cons_vf(E_idx)%sf(j - 2, k - 2, l - 2), q_cons_vf(alf_idx)%sf(j - 2, & - & k - 2, l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) + & k - 2, l - 2), dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T) end if ! Compute mixture sound speed call s_compute_speed_of_sound(pres, rho, gamma, pi_inf, ((gamma + 1._wp)*pres + pi_inf)/rho, alpha, & - & 0._wp, 0._wp, c, qv) + & 0._wp, 0._wp, c, qv) accel = accel_mag(j - 2, k - 2, l - 2) end if @@ -1393,23 +1420,22 @@ contains if (bubbles_euler .and. (num_fluids <= 2)) then if (qbmm) then write (i + 30, '(6x,f12.6,14f28.16)') nondim_time, rho, vel(1), pres, alf, R(1), Rdot(1), nR(1), & - & nRdot(1), varR, varV, M10, M01, M20, M02 + & nRdot(1), varR, varV, M10, M01, M20, M02 else write (i + 30, '(6x,f12.6,8f24.8)') nondim_time, rho, vel(1), pres, alf, R(1), Rdot(1), nR(1), nRdot(1) - ! ptilde, & - ! ptot + ! ptilde, & ptot end if else if (bubbles_euler .and. (num_fluids == 3)) then write (i + 30, & - & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8, f24.8)') nondim_time, & - & rho, vel(1), pres, alf, alfgr, nR(1), nRdot(1), R(1), Rdot(1), ptilde, ptot + & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8, f24.8)') & + & nondim_time, rho, vel(1), pres, alf, alfgr, nR(1), nRdot(1), R(1), Rdot(1), ptilde, ptot else if (bubbles_euler .and. num_fluids == 4) then write (i + 30, & - & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8)') & - & nondim_time, q_cons_vf(1)%sf(j - 2, 0, 0), q_cons_vf(2)%sf(j - 2, 0, 0), q_cons_vf(3)%sf(j - 2, 0, & - & 0), q_cons_vf(4)%sf(j - 2, 0, 0), q_cons_vf(5)%sf(j - 2, 0, 0), q_cons_vf(6)%sf(j - 2, 0, 0), & - & q_cons_vf(7)%sf(j - 2, 0, 0), q_cons_vf(8)%sf(j - 2, 0, 0), q_cons_vf(9)%sf(j - 2, 0, 0), & - & q_cons_vf(10)%sf(j - 2, 0, 0), nbub, R(1), Rdot(1) + & '(6x,f12.6,f24.8,f24.8,f24.8,f24.8,' // 'f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8,f24.8)') & + & nondim_time, q_cons_vf(1)%sf(j - 2, 0, 0), q_cons_vf(2)%sf(j - 2, 0, 0), q_cons_vf(3)%sf(j - 2, & + & 0, 0), q_cons_vf(4)%sf(j - 2, 0, 0), q_cons_vf(5)%sf(j - 2, 0, 0), q_cons_vf(6)%sf(j - 2, 0, 0), & + & q_cons_vf(7)%sf(j - 2, 0, 0), q_cons_vf(8)%sf(j - 2, 0, 0), q_cons_vf(9)%sf(j - 2, 0, 0), & + & q_cons_vf(10)%sf(j - 2, 0, 0), nbub, R(1), Rdot(1) else write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8)') nondim_time, rho, vel(1), pres end if @@ -1417,12 +1443,12 @@ contains if (bubbles_euler) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 write (i + 30, '(6X,10F24.8)') nondim_time, rho, vel(1), vel(2), pres, alf, nR(1), nRdot(1), R(1), & - & Rdot(1) + & Rdot(1) #:endif else if (elasticity) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,' // 'F24.8,F24.8,F24.8)') nondim_time, rho, & - & vel(1), vel(2), pres, tau_e(1), tau_e(2), tau_e(3) + & vel(1), vel(2), pres, tau_e(1), tau_e(2), tau_e(3) #:endif else write (i + 30, '(6X,F12.6,F24.8,F24.8,F24.8)') nondim_time, rho, vel(1), pres @@ -1431,8 +1457,8 @@ contains else #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 write (i + 30, & - & '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,' // 'F24.8,F24.8,F24.8,F24.8,F24.8,' // 'F24.8)') nondim_time, & - & rho, vel(1), vel(2), vel(3), pres, gamma, pi_inf, qv, c, accel + & '(6X,F12.6,F24.8,F24.8,F24.8,F24.8,' // 'F24.8,F24.8,F24.8,F24.8,F24.8,' // 'F24.8)') & + & nondim_time, rho, vel(1), vel(2), vel(3), pres, gamma, pi_inf, qv, c, accel #:endif end if end if @@ -1464,7 +1490,7 @@ contains end do pres = ((q_cons_vf(E_idx)%sf(j, k, l) - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, k, & - & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma + & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma int_pres = int_pres + (pres - 1._wp)**2._wp end if end do @@ -1527,7 +1553,7 @@ contains end do pres = ((q_cons_vf(E_idx)%sf(j, k, l) - 0.5_wp*(q_cons_vf(mom_idx%beg)%sf(j, k, & - & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma + & l)**2._wp)/rho)/(1._wp - q_cons_vf(alf_idx)%sf(j, k, l)) - pi_inf - qv)/gamma int_pres = int_pres + abs(pres - 1._wp) max_pres = max(max_pres, abs(pres - 1._wp)) end if @@ -1556,14 +1582,17 @@ contains end do end if end if + end subroutine s_write_probe_files !> The goal of this subroutine is to write to the run-time information file basic footer information applicable to the current !! computation and to close the file when done. The footer contains the stability criteria extrema over all of the time-steps !! and the simulation run-time. impure subroutine s_close_run_time_information_file + real(wp) :: run_time !< Run-time of the simulation ! Writing the footer of and closing the run-time information file + write (3, '(A)') ' ' write (3, '(A)') '' @@ -1577,34 +1606,45 @@ contains write (3, '(A,I0,A)') 'Run-time: ', int(anint(run_time)), 's' write (3, '(A)') ' ' close (3) + end subroutine s_close_run_time_information_file !> Closes communication files impure subroutine s_close_com_files() + integer :: i !< Generic loop iterator + do i = 1, num_fluids close (i + 120) end do + end subroutine s_close_com_files !> Closes probe files impure subroutine s_close_probe_files + integer :: i !< Generic loop iterator + do i = 1, num_probes close (i + 30) end do + end subroutine s_close_probe_files impure subroutine s_close_ib_state_file + close (ib_state_unit) + end subroutine s_close_ib_state_file !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_data_output_module + integer :: i, m_ds, n_ds, p_ds ! Allocating/initializing ICFL, VCFL, CCFL and Rc stability criteria + if (run_time_info) then @:ALLOCATE(icfl_sf(0:m, 0:n, 0:p)) icfl_max = 0._wp @@ -1632,10 +1672,12 @@ contains allocate (q_cons_temp_ds(i)%sf(-1:m_ds + 1, -1:n_ds + 1, -1:p_ds + 1)) end do end if + end subroutine s_initialize_data_output_module !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_data_output_module + integer :: i if (probe_wrt) then @@ -1656,5 +1698,7 @@ contains end do deallocate (q_cons_temp_ds) end if + end subroutine s_finalize_data_output_module + end module m_data_output diff --git a/src/simulation/m_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index 084a9ebad9..de1703c921 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -7,10 +7,11 @@ #:include 'macros.fpp' module m_derived_variables - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Data output module + use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_data_output !< Data output module use m_compile_specific use m_helper use m_finite_differences @@ -37,17 +38,16 @@ module m_derived_variables real(wp), public, allocatable, dimension(:,:,:) :: x_accel, y_accel, z_accel !> @} $:GPU_DECLARE(create='[accel_mag, x_accel, y_accel, z_accel]') + contains - !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module + !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_derived_variables_module - ! Allocating the variables which will store the coefficients of the - ! centered family of finite-difference schemes. Note that sufficient - ! space is allocated so that the coefficients up to any chosen order - ! of accuracy may be bookkept. However, if higher than fourth-order - ! accuracy coefficients are wanted, the formulae required to compute - ! these coefficients will have to be implemented in the subroutine - ! s_compute_finite_difference_coefficients. + + ! Allocating the variables which will store the coefficients of the centered family of finite-difference schemes. Note that + ! sufficient space is allocated so that the coefficients up to any chosen order of accuracy may be bookkept. However, if + ! higher than fourth-order accuracy coefficients are wanted, the formulae required to compute these coefficients will have + ! to be implemented in the subroutine s_compute_finite_difference_coefficients. ! Allocating centered finite-difference coefficients if (probe_wrt) then @@ -68,10 +68,12 @@ contains end if end if end if + end subroutine s_initialize_derived_variables_module !> Allocate and open derived variables. Computing FD coefficients. impure subroutine s_initialize_derived_variables + if (probe_wrt) then ! Opening and writing header of flow probe files if (proc_rank == 0) then @@ -91,6 +93,7 @@ contains $:GPU_UPDATE(device='[fd_coeff_z]') end if end if + end subroutine s_initialize_derived_variables !> Writes coherent body information, communication files, and probes. @@ -99,19 +102,21 @@ contains !! @param q_prim_ts1 Primitive variables at time-stage 1 !! @param q_prim_ts2 Primitive variables at time-stage 2 subroutine s_compute_derived_variables(t_step, q_cons_vf, q_prim_ts1, q_prim_ts2) + integer, intent(in) :: t_step type(scalar_field), dimension(:), intent(inout) :: q_cons_vf type(vector_field), dimension(:), intent(inout) :: q_prim_ts1, q_prim_ts2 integer :: i, j, k !< Generic loop iterators + if (probe_wrt) then call s_derive_acceleration_component(1, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, x_accel) if (n > 0) then call s_derive_acceleration_component(2, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, & - & y_accel) + & y_accel) end if if (p > 0) then call s_derive_acceleration_component(3, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, & - & z_accel) + & z_accel) end if $:GPU_PARALLEL_LOOP(private='[i, j, k]', collapse=3) @@ -138,6 +143,7 @@ contains call s_write_com_files(t_step, c_mass) end if + end subroutine s_compute_derived_variables !> This subroutine receives as inputs the indicator of the component of the acceleration that should be outputted and the @@ -150,6 +156,7 @@ contains !! @param q_prim_vf3 Primitive variables !! @param q_sf Acceleration component subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, q_prim_vf2, q_prim_vf3, q_sf) + integer, intent(in) :: i type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf0 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf1 @@ -158,13 +165,14 @@ contains real(wp), dimension(0:m, 0:n, 0:p), intent(out) :: q_sf integer :: j, k, l, r !< Generic loop iterators ! Computing the acceleration component in the x-coordinate direction + if (i == 1) then $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p do k = 0, n do j = 0, m q_sf(j, k, l) = (11._wp*q_prim_vf0(momxb)%sf(j, k, l) - 18._wp*q_prim_vf1(momxb)%sf(j, k, & - & l) + 9._wp*q_prim_vf2(momxb)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb)%sf(j, k, l))/(6._wp*dt) + & l) + 9._wp*q_prim_vf2(momxb)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb)%sf(j, k, l))/(6._wp*dt) end do end do end do @@ -177,7 +185,7 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) end do end do end do @@ -190,8 +198,8 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) end do end do end do @@ -205,9 +213,9 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & - & l)*q_prim_vf0(momxb)%sf(j, k, r + l)/y_cc(k) + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxb)%sf(j, k, r + l)/y_cc(k) end do end do end do @@ -220,9 +228,9 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & - & l)*q_prim_vf0(momxb)%sf(j, k, r + l) + & j)*q_prim_vf0(momxb)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxb)%sf(j, k, r + l) end do end do end do @@ -237,7 +245,7 @@ contains do k = 0, n do j = 0, m q_sf(j, k, l) = (11._wp*q_prim_vf0(momxb + 1)%sf(j, k, l) - 18._wp*q_prim_vf1(momxb + 1)%sf(j, k, & - & l) + 9._wp*q_prim_vf2(momxb + 1)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb + 1)%sf(j, k, l))/(6._wp*dt) + & l) + 9._wp*q_prim_vf2(momxb + 1)%sf(j, k, l) - 2._wp*q_prim_vf3(momxb + 1)%sf(j, k, l))/(6._wp*dt) end do end do end do @@ -250,8 +258,8 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) end do end do end do @@ -265,10 +273,10 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & - & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & - & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, & - & r + l)/y_cc(k) - (q_prim_vf0(momxe)%sf(j, k, l)**2._wp)/y_cc(k) + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & + & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & + & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, & + & r + l)/y_cc(k) - (q_prim_vf0(momxe)%sf(j, k, l)**2._wp)/y_cc(k) end do end do end do @@ -281,9 +289,9 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & - & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & - & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, r + l) + & j)*q_prim_vf0(momxb + 1)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, & + & l)*fd_coeff_y(r, k)*q_prim_vf0(momxb + 1)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, & + & l)*fd_coeff_z(r, l)*q_prim_vf0(momxb + 1)%sf(j, k, r + l) end do end do end do @@ -298,7 +306,7 @@ contains do k = 0, n do j = 0, m q_sf(j, k, l) = (11._wp*q_prim_vf0(momxe)%sf(j, k, l) - 18._wp*q_prim_vf1(momxe)%sf(j, k, & - & l) + 9._wp*q_prim_vf2(momxe)%sf(j, k, l) - 2._wp*q_prim_vf3(momxe)%sf(j, k, l))/(6._wp*dt) + & l) + 9._wp*q_prim_vf2(momxe)%sf(j, k, l) - 2._wp*q_prim_vf3(momxe)%sf(j, k, l))/(6._wp*dt) end do end do end do @@ -311,10 +319,10 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & - & l)*q_prim_vf0(momxe)%sf(j, k, r + l)/y_cc(k) + (q_prim_vf0(momxe)%sf(j, k, & - & l)*q_prim_vf0(momxb + 1)%sf(j, k, l))/y_cc(k) + & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxe)%sf(j, k, r + l)/y_cc(k) + (q_prim_vf0(momxe)%sf(j, k, & + & l)*q_prim_vf0(momxb + 1)%sf(j, k, l))/y_cc(k) end do end do end do @@ -327,9 +335,9 @@ contains do j = 0, m do r = -fd_number, fd_number q_sf(j, k, l) = q_sf(j, k, l) + q_prim_vf0(momxb)%sf(j, k, l)*fd_coeff_x(r, & - & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & - & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & - & l)*q_prim_vf0(momxe)%sf(j, k, r + l) + & j)*q_prim_vf0(momxe)%sf(r + j, k, l) + q_prim_vf0(momxb + 1)%sf(j, k, l)*fd_coeff_y(r, & + & k)*q_prim_vf0(momxe)%sf(j, r + k, l) + q_prim_vf0(momxe)%sf(j, k, l)*fd_coeff_z(r, & + & l)*q_prim_vf0(momxe)%sf(j, k, r + l) end do end do end do @@ -337,6 +345,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if + end subroutine s_derive_acceleration_component !> This subroutine is used together with the volume fraction model and when called upon, it computes the location of of the @@ -345,11 +354,13 @@ contains !! @param q_vf Primitive variables !! @param c_m Mass,x-location,y-location,z-location impure subroutine s_derive_center_of_mass(q_vf, c_m) - type(scalar_field), dimension(sys_size), intent(in) :: q_vf + + type(scalar_field), dimension(sys_size), intent(in) :: q_vf real(wp), dimension(1:num_fluids, 1:5), intent(inout) :: c_m - integer :: i, j, k, l !< Generic loop iterators - real(wp) :: tmp, tmp_out !< Temporary variable to store quantity for mpi_allreduce - real(wp) :: dV !< Discrete cell volume + integer :: i, j, k, l !< Generic loop iterators + real(wp) :: tmp, tmp_out !< Temporary variable to store quantity for mpi_allreduce + real(wp) :: dV !< Discrete cell volume + c_m(:,:) = 0.0_wp $:GPU_UPDATE(device='[c_m]') @@ -497,10 +508,12 @@ contains c_m(i, 4) = c_m(i, 4)/c_m(i, 1) end do end if + end subroutine s_derive_center_of_mass !> Deallocation procedures for the module impure subroutine s_finalize_derived_variables_module + ! Closing CoM and flow probe files if (proc_rank == 0) then call s_close_com_files() @@ -519,10 +532,12 @@ contains end if end if - ! Deallocating the variables that might have been used to bookkeep - ! the finite-difference coefficients in the x-, y- and z-directions + ! 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) + end subroutine s_finalize_derived_variables_module + end module m_derived_variables diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 2656fc422f..757525eaa7 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -6,11 +6,12 @@ !> @brief Forward and inverse FFT wrappers (FFTW/cuFFT/hipFFT) for azimuthal Fourier filtering in cylindrical geometries module m_fftw + use, intrinsic :: iso_c_binding - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy #if defined(MFC_GPU) && defined(__PGI) use cufft #elif defined(MFC_GPU) @@ -54,13 +55,16 @@ module m_fftw integer, allocatable :: gpu_fft_size(:), iembed(:), oembed(:) integer :: istride, ostride, idist, odist, rank #endif + contains !> The purpose of this subroutine is to create the fftw plan that will be used in the forward and backward DFTs when applying !! the Fourier filter in the azimuthal direction. impure subroutine s_initialize_fftw_module + integer :: ierr !< Generic flag used to identify and report GPU errors ! Size of input array going into DFT + real_size = p + 1 ! Size of output array coming out of DFT cmplx_size = (p + 1)/2 + 1 @@ -100,26 +104,29 @@ contains #if defined(__PGI) ierr = cufftPlanMany(fwd_plan_gpu, rank, gpu_fft_size, iembed, istride, real_size, oembed, ostride, cmplx_size, & - & CUFFT_D2Z, batch_size) + & CUFFT_D2Z, batch_size) ierr = cufftPlanMany(bwd_plan_gpu, rank, gpu_fft_size, iembed, istride, cmplx_size, oembed, ostride, real_size, & - & CUFFT_Z2D, batch_size) + & CUFFT_Z2D, batch_size) #else ierr = hipfftPlanMany(fwd_plan_gpu, rank, gpu_fft_size, iembed, istride, real_size, oembed, ostride, cmplx_size, & - & HIPFFT_D2Z, batch_size) + & HIPFFT_D2Z, batch_size) ierr = hipfftPlanMany(bwd_plan_gpu, rank, gpu_fft_size, iembed, istride, cmplx_size, oembed, ostride, real_size, & - & HIPFFT_Z2D, batch_size) + & HIPFFT_Z2D, batch_size) #endif #endif + end subroutine s_initialize_fftw_module !> The purpose of this subroutine is to apply a Fourier low- pass filter to the flow variables in the azimuthal direction to !! remove the high-frequency content. This alleviates the restrictive CFL condition arising from cells near the axis. - !! @param q_cons_vf Conservative variables + !! @param q_cons_vf Conservative variables impure subroutine s_apply_fourier_filter(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf integer :: i, j, k, l !< Generic loop iterators integer :: ierr !< Generic flag used to identify and report GPU errors ! Restrict filter to processors that have cells adjacent to axis + if (bc_y%beg >= 0) return #if defined(MFC_GPU) @@ -159,7 +166,7 @@ contains do j = 0, m do l = 1, Nfq data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k - 1) & - & *cmplx_size*x_size) + & *cmplx_size*x_size) end do end do end do @@ -179,7 +186,7 @@ contains do j = 0, m do l = 0, p data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k - 1) & - & *real_size*x_size)/real(real_size, dp) + & *real_size*x_size)/real(real_size, dp) q_cons_vf(k)%sf(j, 0, l) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) end do end do @@ -224,7 +231,7 @@ contains do j = 0, m do l = 1, Nfq data_fltr_cmplx_gpu(l + j*cmplx_size + (k - 1)*cmplx_size*x_size) = data_cmplx_gpu(l + j*cmplx_size + (k & - & - 1)*cmplx_size*x_size) + & - 1)*cmplx_size*x_size) end do end do end do @@ -244,7 +251,7 @@ contains do j = 0, m do l = 0, p data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) = data_real_gpu(l + j*real_size + 1 + (k & - & - 1)*real_size*x_size)/real(real_size, dp) + & - 1)*real_size*x_size)/real(real_size, dp) q_cons_vf(k)%sf(j, i, l) = data_real_gpu(l + j*real_size + 1 + (k - 1)*real_size*x_size) end do end do @@ -281,13 +288,16 @@ contains end do end do #endif + end subroutine s_apply_fourier_filter !> The purpose of this subroutine is to destroy the fftw plan that will be used in the forward and backward DFTs when applying !! the Fourier filter in the azimuthal direction. impure subroutine s_finalize_fftw_module + #if defined(MFC_GPU) integer :: ierr !< Generic flag used to identify and report GPU errors + @:DEALLOCATE(data_real_gpu, data_fltr_cmplx_gpu, data_cmplx_gpu) #if defined(__PGI) @@ -305,5 +315,7 @@ contains call fftw_destroy_plan(fwd_plan) call fftw_destroy_plan(bwd_plan) #endif + end subroutine s_finalize_fftw_module + end module m_fftw diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 53b957d54a..4748d68520 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -7,12 +7,13 @@ !> @brief Global parameters for the computational domain, fluid properties, and simulation algorithm configuration module m_global_parameters + #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif use m_derived_types !< Definitions of the derived types - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers ! $:USE_GPU_MODULE() implicit none @@ -49,20 +50,17 @@ module m_global_parameters !> @name Cell-boundary (CB) locations in the x-, y- and z-directions, respectively !> @{ - real(wp), target, allocatable, dimension(:) :: x_cb, y_cb, z_cb !> @} !> @name Cell-center (CC) locations in the x-, y- and z-directions, respectively !> @{ - real(wp), target, allocatable, dimension(:) :: x_cc, y_cc, z_cc !> @} ! type(bounds_info) :: x_domain, y_domain, z_domain !< !! Locations of the domain bounds in the x-, y- and z-coordinate directions !> @name Cell-width distributions in the x-, y- and z-directions, respectively !> @{ - real(wp), target, allocatable, dimension(:) :: dx, dy, dz !> @} @@ -146,9 +144,8 @@ module m_global_parameters !> @{ logical :: nv_uvm_out_of_core ! Enable out-of-core storage of q_cons_ts(2) in timestepping (default FALSE) integer :: nv_uvm_igr_temps_on_gpu ! 0 => jac, jac_rhs, and jac_old on CPU - ! 1 => jac on GPU, jac_rhs and jac_old on CPU - ! 2 => jac and jac_rhs on GPU, jac_old on CPU - ! 3 => jac, jac_rhs, and jac_old on GPU (default) + ! 1 => jac on GPU, jac_rhs and jac_old on CPU 2 => jac and jac_rhs on GPU, jac_old on CPU 3 => jac, jac_rhs, and jac_old on GPU + ! (default) logical :: nv_uvm_pref_gpu ! Enable explicit gpu memory hints (default FALSE) !> @} @@ -181,7 +178,7 @@ module m_global_parameters real(wp) :: alf_factor !< alpha factor for IGR logical :: bodyForces logical :: bf_x, bf_y, bf_z !< body force toggle in three directions - !< amplitude, frequency, and phase shift sinusoid in each direction + !> amplitude, frequency, and phase shift sinusoid in each direction #:for dir in {'x', 'y', 'z'} #:for param in {'k','w','p','g'} real(wp) :: ${param}$_${dir}$ @@ -278,14 +275,12 @@ module m_global_parameters $:GPU_DECLARE(create='[pi_inf_idx, B_idx, stress_idx, xi_idx, b_size]') $:GPU_DECLARE(create='[tensor_size, species_idx, c_idx]') - ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). - ! Stands for "InDices With INTerior". + ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). Stands for "InDices With INTerior". type(int_bounds_info) :: idwint(1:3) $:GPU_DECLARE(create='[idwint]') - ! Cell Indices for the entire (local) domain. In simulation and post_process, - ! this includes the buffer region. idwbuff and idwint are the same otherwise. - ! Stands for "InDices With BUFFer". + ! Cell Indices for the entire (local) domain. In simulation and post_process, this includes the buffer region. idwbuff and + ! idwint are the same otherwise. Stands for "InDices With BUFFer". type(int_bounds_info) :: idwbuff(1:3) $:GPU_DECLARE(create='[idwbuff]') @@ -299,11 +294,9 @@ module m_global_parameters $:GPU_DECLARE(create='[Re_size, Re_size_max, Re_idx]') - ! The WENO average (WA) flag regulates whether the calculation of any cell- - ! average spatial derivatives is carried out in each cell by utilizing the - ! arithmetic mean of the left and right, WENO-reconstructed, cell-boundary - ! values or simply, the unaltered left and right, WENO-reconstructed, cell- - ! boundary values. + ! The WENO average (WA) flag regulates whether the calculation of any cell- average spatial derivatives is carried out in each + ! cell by utilizing the arithmetic mean of the left and right, WENO-reconstructed, cell-boundary values or simply, the unaltered + ! left and right, WENO-reconstructed, cell- boundary values. !> @{ real(wp) :: wa_flg !> @} @@ -372,10 +365,9 @@ module m_global_parameters type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l integer :: Np - !! Database of the immersed boundary patch parameters for each of the - !! patches employed in the configuration of the initial condition. Note that - !! the maximum allowable number of patches, num_patches_max, may be changed - !! in the module m_derived_types.f90. + !! Database of the immersed boundary patch parameters for each of the patches employed in the configuration of the initial + !! condition. Note that the maximum allowable number of patches, num_patches_max, may be changed in the module + !! m_derived_types.f90. $:GPU_DECLARE(create='[ib, num_ibs, patch_ib, Np, airfoil_grid_u, airfoil_grid_l]') !> @} @@ -399,7 +391,7 @@ module m_global_parameters $:GPU_DECLARE(create='[weight, R0]') logical :: bubbles_euler !< Bubbles euler on/off - logical :: polytropic !< Polytropic switch + logical :: polytropic !< Polytropic switch logical :: polydisperse !< Polydisperse bubbles $:GPU_DECLARE(create='[bubbles_euler, polytropic, polydisperse]') @@ -431,7 +423,6 @@ module m_global_parameters type(scalar_field), allocatable, dimension(:) :: mom_sp type(scalar_field), allocatable, dimension(:,:,:) :: mom_3d $:GPU_DECLARE(create='[mom_sp, mom_3d]') - !> @} type(chemistry_parameters) :: chem_params @@ -464,7 +455,6 @@ module m_global_parameters !> @name Surface tension parameters !> @{ - real(wp) :: sigma logical :: surface_tension $:GPU_DECLARE(create='[sigma, surface_tension]') @@ -522,13 +512,16 @@ module m_global_parameters real(wp) :: hyper_cleaning_tau !< Hyperbolic cleaning tau $:GPU_DECLARE(create='[hyper_cleaning_speed, hyper_cleaning_tau]') !> @} + contains !> Assigns default values to the user inputs before reading them in. This enables for an easier consistency check of these !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs + integer :: i, j !< Generic loop iterator ! Logistics + case_dir = '.' run_time_info = .false. t_step_old = dflt_int @@ -722,7 +715,7 @@ contains bodyForces = .false. bf_x = .false.; bf_y = .false.; bf_z = .false. - !< amplitude, frequency, and phase shift sinusoid in each direction + !> amplitude, frequency, and phase shift sinusoid in each direction #:for dir in {'x', 'y', 'z'} #:for param in {'k','w','p','g'} ${param}$_${dir}$ = dflt_real @@ -859,16 +852,19 @@ contains patch_ib(i)%rotation_matrix(3, 3) = 1._wp patch_ib(i)%rotation_matrix_inverse = patch_ib(i)%rotation_matrix end do + end subroutine s_assign_default_values_to_user_inputs !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_global_parameters_module + integer :: i, j, k integer :: fac #:if not MFC_CASE_OPTIMIZATION ! Determining the degree of the WENO polynomials + if (recon_type == WENO_TYPE) then weno_polyn = (weno_order - 1)/2 if (teno) then @@ -886,19 +882,16 @@ contains $:GPU_UPDATE(device='[igr, igr_order, igr_iter_solver]') #:endif - ! Initializing the number of fluids for which viscous effects will - ! be non-negligible, the number of distinctive material interfaces - ! for which surface tension will be important and also, the number - ! of fluids for which the physical and geometric curvatures of the - ! interfaces will be computed + ! Initializing the number of fluids for which viscous effects will be non-negligible, the number of distinctive material + ! interfaces for which surface tension will be important and also, the number of fluids for which the physical and geometric + ! curvatures of the interfaces will be computed Re_size = 0 Re_size_max = 0 ! Gamma/Pi_inf Model if (model_eqns == 1) then - ! Annotating structure of the state and flux vectors belonging - ! to the system of equations defined by the selected number of - ! spatial dimensions and the gamma/pi_inf model + ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number + ! of spatial dimensions and the gamma/pi_inf model cont_idx%beg = 1 cont_idx%end = cont_idx%beg mom_idx%beg = cont_idx%end + 1 @@ -913,9 +906,8 @@ contains ! Volume Fraction Model else - ! Annotating structure of the state and flux vectors belonging - ! to the system of equations defined by the selected number of - ! spatial dimensions and the volume fraction model + ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number + ! of spatial dimensions and the volume fraction model if (model_eqns == 2) then cont_idx%beg = 1 cont_idx%end = num_fluids @@ -924,17 +916,14 @@ contains E_idx = mom_idx%end + 1 if (igr) then - ! Volume fractions are stored in the indices immediately following - ! the energy equation. IGR tracks a total of (N-1) volume fractions - ! for N fluids, hence the "-1" in adv_idx%end. If num_fluids = 1 - ! then adv_idx%end < adv_idx%beg, which skips all loops over the - ! volume fractions since there is no volume fraction to track + ! Volume fractions are stored in the indices immediately following the energy equation. IGR tracks a total of + ! (N-1) volume fractions for N fluids, hence the "-1" in adv_idx%end. If num_fluids = 1 then adv_idx%end < + ! adv_idx%beg, which skips all loops over the volume fractions since there is no volume fraction to track adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 adv_idx%end = E_idx + num_fluids - 1 else - ! Volume fractions are stored in the indices immediately following - ! the energy equation. WENO/MUSCL + Riemann tracks a total of (N) - ! volume fractions for N fluids, hence the lack of "-1" in adv_idx%end + ! Volume fractions are stored in the indices immediately following the energy equation. WENO/MUSCL + Riemann + ! tracks a total of (N) volume fractions for N fluids, hence the lack of "-1" in adv_idx%end adv_idx%beg = E_idx + 1 adv_idx%end = E_idx + num_fluids end if @@ -1064,8 +1053,8 @@ contains end if end if - ! Determining the number of fluids for which the shear and the - ! volume Reynolds numbers, e.g. viscous effects, are important + ! Determining the number of fluids for which the shear and the volume Reynolds numbers, e.g. viscous effects, are + ! important do i = 1, num_fluids if (fluid_pp(i)%Re(1) > 0) Re_size(1) = Re_size(1) + 1 if (fluid_pp(i)%Re(2) > 0) Re_size(2) = Re_size(2) + 1 @@ -1078,8 +1067,8 @@ contains $:GPU_UPDATE(device='[Re_size, Re_size_max, shear_stress, bulk_stress]') - ! Bookkeeping the indexes of any viscous fluids and any pairs of - ! fluids whose interface will support effects of surface tension + ! Bookkeeping the indexes of any viscous fluids and any pairs of fluids whose interface will support effects of surface + ! tension if (viscous) then @:ALLOCATE(Re_idx(1:2, 1:Re_size_max)) @@ -1124,9 +1113,7 @@ contains shear_BC_flip_indices(1, 1:2) = shear_indices((/1, 2/)) shear_BC_flip_indices(2, 1:2) = shear_indices((/1, 3/)) shear_BC_flip_indices(3, 1:2) = shear_indices((/2, 3/)) - ! x-dir: flip tau_xy and tau_xz - ! y-dir: flip tau_xy and tau_yz - ! z-dir: flip tau_xz and tau_yz + ! x-dir: flip tau_xy and tau_xz y-dir: flip tau_xy and tau_yz z-dir: flip tau_xz and tau_yz end if $:GPU_UPDATE(device='[shear_num, shear_indices, shear_BC_flip_num, shear_BC_flip_indices]') end if @@ -1195,11 +1182,9 @@ contains end do end if - ! Configuring the WENO average flag that will be used to regulate - ! whether any spatial derivatives are to computed in each cell by - ! using the arithmetic mean of left and right, WENO-reconstructed, - ! cell-boundary values or otherwise, the unaltered left and right, - ! WENO-reconstructed, cell-boundary values + ! Configuring the WENO average flag that will be used to regulate whether any spatial derivatives are to computed in each + ! cell by using the arithmetic mean of left and right, WENO-reconstructed, cell-boundary values or otherwise, the unaltered + ! left and right, WENO-reconstructed, cell-boundary values wa_flg = 0._wp; if (weno_avg) wa_flg = 1._wp $:GPU_UPDATE(device='[wa_flg]') @@ -1224,7 +1209,7 @@ contains end if call s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & - & bubbles_lagrange, m, n, p, num_dims, igr, ib) + & bubbles_lagrange, m, n, p, num_dims, igr, ib) $:GPU_UPDATE(device='[idwint, idwbuff]') ! Configuring Coordinate Direction Indexes @@ -1260,7 +1245,8 @@ contains chemxe = species_idx%end $:GPU_UPDATE(device='[momxb, momxe, advxb, advxe, contxb, contxe, bubxb, bubxe, intxb, intxe, sys_size, buff_size, E_idx, & - & alf_idx, n_idx, adv_n, adap_dt, pi_fac, strxb, strxe, chemxb, chemxe, c_idx, adap_dt_tol, adap_dt_max_iters]') + & alf_idx, n_idx, adv_n, adap_dt, pi_fac, strxb, strxe, chemxb, chemxe, c_idx, adap_dt_tol, & + & adap_dt_max_iters]') $:GPU_UPDATE(device='[b_size, xibeg, xiend, tensor_size]') $:GPU_UPDATE(device='[species_idx]') @@ -1268,8 +1254,9 @@ contains $:GPU_UPDATE(device='[alt_soundspeed, acoustic_source, num_source]') $:GPU_UPDATE(device='[dt, sys_size, buff_size, pref, rhoref, gamma_idx, pi_inf_idx, E_idx, alf_idx, stress_idx, mpp_lim, & - & bubbles_euler, hypoelasticity, alt_soundspeed, avg_state, model_eqns, mixture_err, grid_geometry, cyl_coord, mp_weno, & - & weno_eps, teno_CT, hyperelasticity, hyper_model, elasticity, xi_idx, B_idx, low_Mach]') + & bubbles_euler, hypoelasticity, alt_soundspeed, avg_state, model_eqns, mixture_err, grid_geometry, & + & cyl_coord, & + & mp_weno, weno_eps, teno_CT, hyperelasticity, hyper_model, elasticity, xi_idx, B_idx, low_Mach]') $:GPU_UPDATE(device='[Bx0]') @@ -1315,15 +1302,18 @@ contains @:PREFER_GPU(z_cb) @:PREFER_GPU(z_cc) @:PREFER_GPU(dz) + end subroutine s_initialize_global_parameters_module !> Initializes parallel infrastructure impure subroutine s_initialize_parallel_io + #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors #endif #:if not MFC_CASE_OPTIMIZATION + num_dims = 1 + min(1, n) + min(1, p) if (mhd) then @@ -1346,22 +1336,22 @@ contains call MPI_INFO_CREATE(mpi_info_int, ierr) call MPI_INFO_SET(mpi_info_int, 'romio_ds_write', 'disable', ierr) - ! Option for UNIX file system (Hooke/Thomson) - ! WRITE(mpiiofs, '(A)') '/ufs_' - ! mpiiofs = TRIM(mpiiofs) - ! mpi_info_int = MPI_INFO_NULL + ! Option for UNIX file system (Hooke/Thomson) WRITE(mpiiofs, '(A)') '/ufs_' mpiiofs = TRIM(mpiiofs) mpi_info_int = + ! MPI_INFO_NULL allocate (start_idx(1:num_dims)) #endif + end subroutine s_initialize_parallel_io !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_global_parameters_module + integer :: i - ! Deallocating the variables bookkeeping the indexes of any viscous - ! fluids and any pairs of fluids whose interfaces supported effects - ! of surface tension + ! Deallocating the variables bookkeeping the indexes of any viscous fluids and any pairs of fluids whose interfaces + ! supported effects of surface tension + if (viscous) then @:DEALLOCATE(Re_idx) end if @@ -1394,5 +1384,7 @@ contains if (p == 0) return; @:DEALLOCATE(z_cb, z_cc, dz) + end subroutine s_finalize_global_parameters_module + end module m_global_parameters diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index a526748264..fb9ddaed4d 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -7,8 +7,9 @@ !> @brief Computes the left Cauchy--Green deformation tensor and hyperelastic stress source terms module m_hyperelastic - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion !< State variables type conversion procedures use m_finite_differences @@ -16,8 +17,8 @@ module m_hyperelastic private; public :: s_hyperelastic_rmt_stress_update, s_initialize_hyperelastic_module, s_finalize_hyperelastic_module - !! The btensor at the cell-interior Gaussian quadrature points. - !! These tensor is needed to be calculated once and make the code DRY. + !! The btensor at the cell-interior Gaussian quadrature points. These tensor is needed to be calculated once and make the code + !! DRY. type(vector_field) :: btensor $:GPU_DECLARE(create='[btensor]') @@ -27,13 +28,16 @@ module m_hyperelastic $:GPU_DECLARE(create='[fd_coeff_x_hyper, fd_coeff_y_hyper, fd_coeff_z_hyper]') real(wp), allocatable, dimension(:) :: Gs_hyper $:GPU_DECLARE(create='[Gs_hyper]') + contains !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. calculate the !! grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the FFtranspose to !! obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space impure subroutine s_initialize_hyperelastic_module + integer :: i !< generic iterator + @:ALLOCATE(btensor%vf(1:b_size)) do i = 1, b_size @:ALLOCATE(btensor%vf(i)%sf(0:m, 0:n, 0:p)) @@ -66,16 +70,16 @@ contains call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z_hyper, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_z_hyper]') end if + end subroutine s_initialize_hyperelastic_module - !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Primitive variables - !! calculate the grad_xi, grad_xi is a nxn tensor - !! calculate the inverse of grad_xi to obtain F, F is a nxn tensor - !! calculate the FFtranspose to obtain the btensor, btensor is nxn tensor - !! btensor is symmetric, save the data space + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. + !! @param q_cons_vf Conservative variables + !! @param q_prim_vf Primitive variables + !! calculate the grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the + !! FFtranspose to obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space subroutine s_hyperelastic_rmt_stress_update(q_cons_vf, q_prim_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf #:if USING_AMD @@ -95,7 +99,7 @@ contains integer :: j, k, l, i, r $:GPU_PARALLEL_LOOP(collapse=3, & - & private='[i, j, k, l, alpha_K, alpha_rho_K, rho, gamma, pi_inf, qv, G_local, Re, tensora, tensorb]') + & private='[i, j, k, l, alpha_K, alpha_rho_K, rho, gamma, pi_inf, qv, G_local, Re, tensora, tensorb]') do l = 0, p do k = 0, n do j = 0, m @@ -103,7 +107,7 @@ contains ! If in simulation, use acc mixture subroutines call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, alpha_k, alpha_rho_k, Re, G_local, & - & Gs_hyper) + & Gs_hyper) rho = max(rho, sgm_eps) G_local = max(G_local, sgm_eps) ! if ( G_local <= verysmall ) G_K = 0._wp @@ -113,11 +117,8 @@ contains do i = 1, tensor_size tensora(i) = 0._wp end do - ! STEP 1: computing the grad_xi tensor using finite differences - ! grad_xi definition / organization - ! number for the tensor 1-3: dxix_dx, dxiy_dx, dxiz_dx - ! 4-6 : dxix_dy, dxiy_dy, dxiz_dy - ! 7-9 : dxix_dz, dxiy_dz, dxiz_dz + ! STEP 1: computing the grad_xi tensor using finite differences grad_xi definition / organization number for + ! the tensor 1-3: dxix_dx, dxiy_dx, dxiz_dx 4-6 : dxix_dy, dxiy_dy, dxiz_dy 7-9 : dxix_dz, dxiy_dz, dxiz_dz $:GPU_LOOP(parallelism='[seq]') do r = -fd_number, fd_number ! derivatives in the x-direction @@ -146,11 +147,10 @@ contains ! STEP 2b: computing the determinant of the grad_xi tensor tensorb(tensor_size) = tensora(1)*(tensora(5)*tensora(9) - tensora(6)*tensora(8)) - tensora(2)*(tensora(4) & - & *tensora(9) - tensora(6)*tensora(7)) + tensora(3)*(tensora(4)*tensora(8) - tensora(5)*tensora(7)) + & *tensora(9) - tensora(6)*tensora(7)) + tensora(3)*(tensora(4)*tensora(8) - tensora(5)*tensora(7)) if (tensorb(tensor_size) > verysmall) then - ! STEP 2c: computing the inverse of grad_xi tensor = F - ! tensorb is the adjoint, tensora becomes F + ! STEP 2c: computing the inverse of grad_xi tensor = F tensorb is the adjoint, tensora becomes F $:GPU_LOOP(parallelism='[seq]') do i = 1, tensor_size - 1 tensora(i) = tensorb(i)/tensorb(tensor_size) @@ -180,7 +180,7 @@ contains end if ! STEP 5b: updating the pressure field q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, l) - G_local*q_prim_vf(xiend + 1)%sf(j, k, & - & l)/gamma + & l)/gamma ! STEP 5c: updating the Cauchy stress conservative scalar field $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size - 1 @@ -192,20 +192,20 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_hyperelastic_rmt_stress_update - !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. - !! @param btensor_in Left Cauchy-Green deformation tensor - !! @param q_prim_vf Primitive variables - !! @param G_param Elastic shear modulus - !! @param j x-direction cell index - !! @param k y-direction cell index - !! @param l z-direction cell index - !! calculate the grad_xi, grad_xi is a nxn tensor - !! calculate the inverse of grad_xi to obtain F, F is a nxn tensor - !! calculate the FFtranspose to obtain the btensor, btensor is nxn tensor - !! btensor is symmetric, save the data space + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. + !! @param btensor_in Left Cauchy-Green deformation tensor + !! @param q_prim_vf Primitive variables + !! @param G_param Elastic shear modulus + !! @param j x-direction cell index + !! @param k y-direction cell index + !! @param l z-direction cell index + !! calculate the grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the + !! FFtranspose to obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space subroutine s_neoHookean_cauchy_solver(btensor_in, q_prim_vf, G_param, j, k, l) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf type(scalar_field), dimension(b_size), intent(inout) :: btensor_in @@ -221,28 +221,27 @@ contains #:for IJ in [1,3,6] btensor_in(${IJ}$)%sf(j, k, l) = btensor_in(${IJ}$)%sf(j, k, l) - f13*trace #:endfor - ! dividing by the jacobian for neo-Hookean model - ! setting the tensor to the stresses for riemann solver + ! dividing by the jacobian for neo-Hookean model setting the tensor to the stresses for riemann solver $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size - 1 q_prim_vf(strxb + i - 1)%sf(j, k, l) = G_param*btensor_in(i)%sf(j, k, l)/btensor_in(b_size)%sf(j, k, l) end do ! compute the invariant without the elastic modulus q_prim_vf(xiend + 1)%sf(j, k, l) = 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) + end subroutine s_neoHookean_cauchy_solver - !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. - !! @param btensor_in Left Cauchy-Green deformation tensor - !! @param q_prim_vf Primitive variables - !! @param G_param Elastic shear modulus - !! @param j x-direction cell index - !! @param k y-direction cell index - !! @param l z-direction cell index - !! calculate the grad_xi, grad_xi is a nxn tensor - !! calculate the inverse of grad_xi to obtain F, F is a nxn tensor - !! calculate the FFtranspose to obtain the btensor, btensor is nxn tensor - !! btensor is symmetric, save the data space + !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. + !! @param btensor_in Left Cauchy-Green deformation tensor + !! @param q_prim_vf Primitive variables + !! @param G_param Elastic shear modulus + !! @param j x-direction cell index + !! @param k y-direction cell index + !! @param l z-direction cell index + !! calculate the grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the + !! FFtranspose to obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space subroutine s_Mooney_Rivlin_cauchy_solver(btensor_in, q_prim_vf, G_param, j, k, l) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf type(scalar_field), dimension(b_size), intent(inout) :: btensor_in @@ -251,8 +250,7 @@ contains real(wp) :: trace real(wp), parameter :: f13 = 1._wp/3._wp integer :: i !< Generic loop iterators - ! TODO Make this 1D and 2D capable - ! tensor is the symmetric tensor & calculate the trace of the tensor + ! TODO Make this 1D and 2D capable tensor is the symmetric tensor & calculate the trace of the tensor trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) ! calculate the deviatoric of the tensor @@ -260,20 +258,22 @@ contains btensor_in(3)%sf(j, k, l) = btensor_in(3)%sf(j, k, l) - f13*trace btensor_in(6)%sf(j, k, l) = btensor_in(6)%sf(j, k, l) - f13*trace - ! dividing by the jacobian for neo-Hookean model - ! setting the tensor to the stresses for riemann solver + ! dividing by the jacobian for neo-Hookean model setting the tensor to the stresses for riemann solver $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size - 1 q_prim_vf(strxb + i - 1)%sf(j, k, l) = G_param*btensor_in(i)%sf(j, k, l)/btensor_in(b_size)%sf(j, k, l) end do ! compute the invariant without the elastic modulus q_prim_vf(xiend + 1)%sf(j, k, l) = 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) + end subroutine s_Mooney_Rivlin_cauchy_solver !> @brief Deallocates memory for hyperelastic deformation tensor and finite-difference coefficients. impure subroutine s_finalize_hyperelastic_module() + integer :: i !< iterator ! Deallocating memory + do i = 1, b_size @:DEALLOCATE(btensor%vf(i)%sf) end do @@ -284,5 +284,7 @@ contains @:DEALLOCATE(fd_coeff_z_hyper) end if end if + end subroutine s_finalize_hyperelastic_module + end module m_hyperelastic diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index 535323bfdb..825e1a9145 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -6,7 +6,8 @@ !> @brief Computes hypoelastic stress-rate source terms and damage-state evolution module m_hypoelastic - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_finite_differences use m_helper @@ -31,10 +32,12 @@ module m_hypoelastic real(wp), allocatable, dimension(:,:) :: fd_coeff_y_hypo real(wp), allocatable, dimension(:,:) :: fd_coeff_z_hypo $:GPU_DECLARE(create='[fd_coeff_x_hypo, fd_coeff_y_hypo, fd_coeff_z_hypo]') + contains !> @brief Allocates arrays and computes finite-difference coefficients for the hypoelastic stress model. impure subroutine s_initialize_hypoelastic_module + integer :: i @:ALLOCATE(Gs_hypo(1:num_fluids)) @@ -72,24 +75,26 @@ contains call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z_hypo, buff_size, fd_number, fd_order) $:GPU_UPDATE(device='[fd_coeff_z_hypo]') end if + end subroutine s_initialize_hypoelastic_module - !> The purpose of this procedure is to compute the source terms that are needed for the elastic stress equations + !> The purpose of this procedure is to compute the source terms that are needed for the elastic stress equations !! @param idir Dimension splitting index !! @param q_prim_vf Primitive variables !! @param rhs_vf rhs variables subroutine s_compute_hypoelastic_rhs(idir, q_prim_vf, rhs_vf) + integer, intent(in) :: idir type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf real(wp) :: rho_K, G_K integer :: i, k, l, q, r !< Loop variables integer :: ndirs !< Number of coordinate directions + ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 if (idir == 1) then - ! calculate velocity gradients + rho_K and G_K - ! TODO: re-organize these loops one by one for GPU efficiency if possible? + ! calculate velocity gradients + rho_K and G_K TODO: re-organize these loops one by one for GPU efficiency if possible? $:GPU_PARALLEL_LOOP(collapse=3) do q = 0, p @@ -133,9 +138,9 @@ contains do r = -fd_number, fd_number du_dy_hypo(k, l, q) = du_dy_hypo(k, l, q) + q_prim_vf(momxb)%sf(k, l + r, q)*fd_coeff_y_hypo(r, l) dv_dx_hypo(k, l, q) = dv_dx_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k + r, l, & - & q)*fd_coeff_x_hypo(r, k) + & q)*fd_coeff_x_hypo(r, k) dv_dy_hypo(k, l, q) = dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l + r, & - & q)*fd_coeff_y_hypo(r, l) + & q)*fd_coeff_y_hypo(r, l) end do end do end do @@ -162,15 +167,15 @@ contains $:GPU_LOOP(parallelism='[seq]') do r = -fd_number, fd_number du_dz_hypo(k, l, q) = du_dz_hypo(k, l, q) + q_prim_vf(momxb)%sf(k, l, & - & q + r)*fd_coeff_z_hypo(r, q) + & q + r)*fd_coeff_z_hypo(r, q) dv_dz_hypo(k, l, q) = dv_dz_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, & - & q + r)*fd_coeff_z_hypo(r, q) + & q + r)*fd_coeff_z_hypo(r, q) dw_dx_hypo(k, l, q) = dw_dx_hypo(k, l, q) + q_prim_vf(momxe)%sf(k + r, l, & - & q)*fd_coeff_x_hypo(r, k) + & q)*fd_coeff_x_hypo(r, k) dw_dy_hypo(k, l, q) = dw_dy_hypo(k, l, q) + q_prim_vf(momxe)%sf(k, l + r, & - & q)*fd_coeff_y_hypo(r, l) + & q)*fd_coeff_y_hypo(r, l) dw_dz_hypo(k, l, q) = dw_dz_hypo(k, l, q) + q_prim_vf(momxe)%sf(k, l, & - & q + r)*fd_coeff_z_hypo(r, q) + & q + r)*fd_coeff_z_hypo(r, q) end do end do end do @@ -209,7 +214,7 @@ contains do l = 0, n do k = 0, m rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*((4._wp*G_K_field(k, l, & - & q)/3._wp) + q_prim_vf(strxb)%sf(k, l, q))*du_dx_hypo(k, l, q) + & q)/3._wp) + q_prim_vf(strxb)%sf(k, l, q))*du_dx_hypo(k, l, q) end do end do end do @@ -220,23 +225,24 @@ contains do l = 0, n do k = 0, m rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxb + 1)%sf(k, & - & l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy_hypo(k, l, & - & q) - q_prim_vf(strxb)%sf(k, l, q)*dv_dy_hypo(k, l, q) - 2._wp*G_K_field(k, l, & - & q)*(1._wp/3._wp)*dv_dy_hypo(k, l, q)) + & l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, q)*du_dy_hypo(k, l, & + & q) - q_prim_vf(strxb)%sf(k, l, q)*dv_dy_hypo(k, l, q) - 2._wp*G_K_field(k, l, & + & q)*(1._wp/3._wp)*dv_dy_hypo(k, l, q)) rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & - & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, & - & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & - & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy_hypo(k, l, q) + 2._wp*G_K_field(k, & - & l, q)*(1._wp/2._wp)*(du_dy_hypo(k, l, q) + dv_dx_hypo(k, l, q))) + & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & + & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dy_hypo(k, l, q) + dv_dx_hypo(k, l, q))) rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & - & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*du_dx_hypo(k, l, & - & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & - & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + 2._wp*G_K_field(k, & - & l, q)*(dv_dy_hypo(k, l, q) - (1._wp/3._wp)*(du_dx_hypo(k, l, q) + dv_dy_hypo(k, l, q)))) + & q)*(q_prim_vf(strxb + 1)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dv_dx_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & + & q)*dv_dy_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + 2._wp*G_K_field(k, l, q)*(dv_dy_hypo(k, l, q) - (1._wp/3._wp)*(du_dx_hypo(k, l, & + & q) + dv_dy_hypo(k, l, q)))) end do end do end do @@ -247,45 +253,45 @@ contains do l = 0, n do k = 0, m rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxb + 3)%sf(k, & - & l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz_hypo(k, l, & - & q) - q_prim_vf(strxb)%sf(k, l, q)*dw_dz_hypo(k, l, q) - 2._wp*G_K_field(k, l, & - & q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) + & l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, q)*du_dz_hypo(k, l, & + & q) - q_prim_vf(strxb)%sf(k, l, q)*dw_dz_hypo(k, l, q) - 2._wp*G_K_field(k, l, & + & q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & - & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dz_hypo(k, l, q)) + & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & + & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 1)%sf(k, l, q)*dw_dz_hypo(k, l, q)) rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & - & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dz_hypo(k, l, q) - 2._wp*G_K_field(k, & - & l, q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) + & q)*(q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & + & q)*dv_dz_hypo(k, l, q) - q_prim_vf(strxb + 2)%sf(k, l, q)*dw_dz_hypo(k, l, & + & q) - 2._wp*G_K_field(k, l, q)*(1._wp/3._wp)*dw_dz_hypo(k, l, q)) rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & - & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, & - & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & - & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dy_hypo(k, l, & - & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & - & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, & - & l, q)*(1._wp/2._wp)*(du_dz_hypo(k, l, q) + dw_dx_hypo(k, l, q))) + & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxb)%sf(k, l, & + & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*du_dy_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*du_dz_hypo(k, l, q) + q_prim_vf(strxb + 3)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 3)%sf(k, l, q)*dw_dz_hypo(k, l, & + & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(du_dz_hypo(k, l, q) + dw_dx_hypo(k, l, q))) rhs_vf(strxb + 4)%sf(k, l, q) = rhs_vf(strxb + 4)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & - & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*du_dx_hypo(k, l, & - & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & - & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, & - & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & - & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, & - & l, q)*(1._wp/2._wp)*(dv_dz_hypo(k, l, q) + dw_dy_hypo(k, l, q))) + & q)*(q_prim_vf(strxb + 3)%sf(k, l, q)*dv_dx_hypo(k, l, q) + q_prim_vf(strxb + 1)%sf(k, l, & + & q)*dw_dx_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*du_dx_hypo(k, l, & + & q) + q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxb + 2)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dv_dy_hypo(k, l, & + & q) + q_prim_vf(strxb + 5)%sf(k, l, q)*dv_dz_hypo(k, l, q) + q_prim_vf(strxb + 4)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxb + 4)%sf(k, l, q)*dw_dz_hypo(k, l, & + & q) + 2._wp*G_K_field(k, l, q)*(1._wp/2._wp)*(dv_dz_hypo(k, l, q) + dw_dy_hypo(k, l, q))) rhs_vf(strxe)%sf(k, l, q) = rhs_vf(strxe)%sf(k, l, q) + rho_K_field(k, l, q)*(q_prim_vf(strxe - 2)%sf(k, & - & l, q)*dw_dx_hypo(k, l, q) + q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx_hypo(k, l, & - & q) - q_prim_vf(strxe)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, & - & q)*dw_dy_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy_hypo(k, l, & - & q) - q_prim_vf(strxe)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, & - & l, q) + q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, q) - q_prim_vf(strxe)%sf(k, l, & - & q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, l, q)*(dw_dz_hypo(k, l, & - & q) - (1._wp/3._wp)*(du_dx_hypo(k, l, q) + dv_dy_hypo(k, l, q) + dw_dz_hypo(k, l, q)))) + & l, q)*dw_dx_hypo(k, l, q) + q_prim_vf(strxe - 2)%sf(k, l, q)*dw_dx_hypo(k, l, & + & q) - q_prim_vf(strxe)%sf(k, l, q)*du_dx_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, & + & q)*dw_dy_hypo(k, l, q) + q_prim_vf(strxe - 1)%sf(k, l, q)*dw_dy_hypo(k, l, & + & q) - q_prim_vf(strxe)%sf(k, l, q)*dv_dy_hypo(k, l, q) + q_prim_vf(strxe)%sf(k, l, & + & q)*dw_dz_hypo(k, l, q) + q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, & + & q) - q_prim_vf(strxe)%sf(k, l, q)*dw_dz_hypo(k, l, q) + 2._wp*G_K_field(k, l, q)*(dw_dz_hypo(k, & + & l, q) - (1._wp/3._wp)*(du_dx_hypo(k, l, q) + dv_dy_hypo(k, l, q) + dw_dz_hypo(k, l, q)))) end do end do end do @@ -299,32 +305,34 @@ contains do k = 0, m ! S_xx -= rho * v/r * (tau_xx + 2/3*G) rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) - rho_K_field(k, l, q)*q_prim_vf(momxb + 1)%sf(k, & - & l, q)/y_cc(l)*(q_prim_vf(strxb)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_xx + 2/3*G + & l, q)/y_cc(l)*(q_prim_vf(strxb)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_xx + 2/3*G ! S_xr -= rho * v/r * tau_xr rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) - rho_K_field(k, l, & - & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*q_prim_vf(strxb + 1)%sf(k, l, q) ! tau_xx + & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*q_prim_vf(strxb + 1)%sf(k, l, q) ! tau_xx ! S_rr -= rho * v/r * (tau_rr + 2/3*G) rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) - rho_K_field(k, l, & - & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*(q_prim_vf(strxb + 2)%sf(k, l, & - & q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_rr + 2/3*G + & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*(q_prim_vf(strxb + 2)%sf(k, l, & + & q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_rr + 2/3*G ! S_thetatheta += rho * ( -(tau_thetatheta + 2/3*G)*(du/dx + dv/dr + v/r) + 2*(tau_thetatheta + G)*v/r ) rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, & - & q)*(-(q_prim_vf(strxb + 3)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q))*(du_dx_hypo(k, l, & - & q) + dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, & - & q)/y_cc(l)) + 2._wp*(q_prim_vf(strxb + 3)%sf(k, l, q) + G_K_field(k, l, & - & q))*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)) + & q)*(-(q_prim_vf(strxb + 3)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q))*(du_dx_hypo(k, l, & + & q) + dv_dy_hypo(k, l, q) + q_prim_vf(momxb + 1)%sf(k, l, & + & q)/y_cc(l)) + 2._wp*(q_prim_vf(strxb + 3)%sf(k, l, q) + G_K_field(k, l, & + & q))*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)) end do end do end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_compute_hypoelastic_rhs !> @brief Deallocates arrays used by the hypoelastic stress module. impure subroutine s_finalize_hypoelastic_module() + @:DEALLOCATE(Gs_hypo) @:DEALLOCATE(rho_K_field, G_K_field) @:DEALLOCATE(du_dx_hypo) @@ -337,10 +345,12 @@ contains @:DEALLOCATE(fd_coeff_z_hypo) end if end if + end subroutine s_finalize_hypoelastic_module !> @brief Computes the continuum damage source term from the principal stress state. subroutine s_compute_damage_state(q_cons_vf, rhs_vf) + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf real(wp) :: tau_p ! principal stress @@ -353,7 +363,7 @@ contains $:GPU_PARALLEL_LOOP() do k = 0, m rhs_vf(damage_idx)%sf(k, l, q) = (alpha_bar*max(abs(real(q_cons_vf(stress_idx%beg)%sf(k, l, q), & - & kind=wp)) - tau_star, 0._wp))**cont_damage_s + & kind=wp)) - tau_star, 0._wp))**cont_damage_s end do $:END_GPU_PARALLEL_LOOP() else if (p == 0) then @@ -363,8 +373,8 @@ contains do k = 0, m ! Maximum principal stress tau_p = 0.5_wp*(q_cons_vf(stress_idx%beg)%sf(k, l, q) + q_cons_vf(stress_idx%beg + 2)%sf(k, l, & - & q)) + sqrt((q_cons_vf(stress_idx%beg)%sf(k, l, q) - q_cons_vf(stress_idx%beg + 2)%sf(k, l, & - & q))**2.0_wp + 4._wp*q_cons_vf(stress_idx%beg + 1)%sf(k, l, q)**2.0_wp)/2._wp + & q)) + sqrt((q_cons_vf(stress_idx%beg)%sf(k, l, q) - q_cons_vf(stress_idx%beg + 2)%sf(k, l, & + & q))**2.0_wp + 4._wp*q_cons_vf(stress_idx%beg + 1)%sf(k, l, q)**2.0_wp)/2._wp rhs_vf(damage_idx)%sf(k, l, q) = (alpha_bar*max(tau_p - tau_star, 0._wp))**cont_damage_s end do @@ -372,7 +382,7 @@ contains $:END_GPU_PARALLEL_LOOP() else $:GPU_PARALLEL_LOOP(collapse=3, private='[tau_xx, tau_xy, tau_yy, tau_xz, tau_yz, tau_zz, I1, I2, I3, temp, & - & sqrt_term_1, sqrt_term_2, argument, phi, tau_p]') + & sqrt_term_1, sqrt_term_2, argument, phi, tau_p]') do q = 0, p do l = 0, n do k = 0, m @@ -409,5 +419,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_compute_damage_state + end module m_hypoelastic diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index c15b3f69ea..0c35395c01 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -11,10 +11,11 @@ !> @brief Immersed boundary patch geometry constructors for 2D and 3D shapes module m_ib_patches + use m_model ! Subroutine(s) related to STL files use m_derived_types ! Definitions of the derived types use m_global_parameters !< Definitions of the global parameters - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper use m_mpi_common @@ -31,34 +32,34 @@ module m_ib_patches integer :: smooth_patch_id real(wp) :: smooth_coeff $:GPU_DECLARE(create='[smooth_patch_id, smooth_coeff]') - !! These variables are analogous in both meaning and use to the similarly - !! named components in the ic_patch_parameters type (see m_derived_types.f90 - !! for additional details). They are employed as a means to more concisely - !! perform the actions necessary to lay out a particular patch on the grid. + !! These variables are analogous in both meaning and use to the similarly named components in the ic_patch_parameters type (see + !! m_derived_types.f90 for additional details). They are employed as a means to more concisely perform the actions necessary to + !! lay out a particular patch on the grid. real(wp) :: cart_x, cart_y, cart_z real(wp) :: sph_phi $:GPU_DECLARE(create='[cart_x, cart_y, cart_z, sph_phi]') - !! Variables to be used to hold cell locations in Cartesian coordinates if - !! 3D simulation is using cylindrical coordinates + !! Variables to be used to hold cell locations in Cartesian coordinates if 3D simulation is using cylindrical coordinates type(bounds_info) :: x_boundary, y_boundary, z_boundary $:GPU_DECLARE(create='[x_boundary, y_boundary, z_boundary]') - !! These variables combine the centroid and length parameters associated with - !! a particular patch to yield the locations of the patch boundaries in the - !! x-, y- and z-coordinate directions. They are used as a means to concisely - !! perform the actions necessary to lay out a particular patch on the grid. + !! These variables combine the centroid and length parameters associated with a particular patch to yield the locations of the + !! patch boundaries in the x-, y- and z-coordinate directions. They are used as a means to concisely perform the actions + !! necessary to lay out a particular patch on the grid. character(len=5) :: istr ! string to store int to string result for error checking + contains !> @brief Applies all immersed boundary patch geometries to mark interior cells in the IB marker array. impure subroutine s_apply_ib_patches(ib_markers) + type(integer_field), intent(inout) :: ib_markers integer :: i, xp, yp, zp ! iterators integer :: xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper ! periodic bounds ! 3D Patch Geometries + if (p > 0) then !> IB Patches !> @{ @@ -108,15 +109,17 @@ contains end do !> @} end if + end subroutine s_apply_ib_patches !> The circular patch is a 2D geometry that may be used, for example, in creating a bubble or a droplet. The geometry of the !! patch is well-defined when its centroid and radius are provided. Note that the circular patch DOES allow for the smoothing of !! its boundary. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !! @param patch_id is the patch identifier + !! @param ib_markers Array to track patch ids + !! @param ib True if this patch is an immersed boundary subroutine s_ib_circle(patch_id, ib_markers, xp, yp) + integer, intent(in) :: patch_id integer, intent(in) :: xp, yp !< integers containing the periodicity projection information type(integer_field), intent(inout) :: ib_markers @@ -125,8 +128,8 @@ contains integer :: i, j, il, ir, jl, jr !< Generic loop iterators integer :: encoded_patch_id - ! Transferring the circular patch's radius, centroid, smearing patch - ! identity and smearing coefficient information + ! Transferring the circular patch's radius, centroid, smearing patch identity and smearing coefficient information + center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) radius = patch_ib(patch_id)%radius @@ -142,10 +145,8 @@ contains call get_bounding_indices(center(1) - radius, center(1) + radius, x_cc, il, ir) call get_bounding_indices(center(2) - radius, center(2) + radius, y_cc, jl, jr) - ! Checking whether the circle covers a particular cell in the domain - ! and verifying whether the current patch has permission to write to - ! that cell. If both queries check out, the primitive variables of - ! the current patch are assigned to this cell. + ! Checking whether the circle covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. $:GPU_PARALLEL_LOOP(private='[i, j]', copyin='[encoded_patch_id, center, radius]', collapse=2) do j = jl, jr @@ -156,12 +157,14 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_circle !> @brief Marks cells inside a 2D NACA 4-digit airfoil immersed boundary using upper and lower surface grids. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_airfoil(patch_id, ib_markers, xp, yp) + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp !< integers containing the periodicity projection information @@ -259,7 +262,7 @@ contains call get_bounding_indices(center(2) - ca_in, center(2) + ca_in, y_cc, jl, jr) $:GPU_PARALLEL_LOOP(private='[i, j, xy_local, k, f]', copyin='[encoded_patch_id, center, inverse_rotation, offset, ma, & - & ca_in, airfoil_grid_u, airfoil_grid_l]', collapse=2) + & ca_in, airfoil_grid_u, airfoil_grid_l]', collapse=2) do j = jl, jr do i = il, ir xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] ! get coordinate frame centered on IB @@ -315,6 +318,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_airfoil !> @brief Marks cells inside a 3D extruded NACA 4-digit airfoil immersed boundary with finite span. @@ -322,15 +326,16 @@ contains !! @param ib_markers Array to track patch ids !! @param ib True if this patch is an immersed boundary subroutine s_ib_3D_airfoil(patch_id, ib_markers, xp, yp, zp) - integer, intent(in) :: patch_id + + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - real(wp) :: lz, z_max, z_min, f, ca_in, pa, ma, ta, xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c - integer :: i, j, k, l, il, ir, jl, jr, ll, lr - integer :: Np1, Np2 - integer :: encoded_patch_id - real(wp), dimension(1:3) :: xyz_local, center, offset !< x, y, z coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + real(wp) :: lz, z_max, z_min, f, ca_in, pa, ma, ta, xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c + integer :: i, j, k, l, il, ir, jl, jr, ll, lr + integer :: Np1, Np2 + integer :: encoded_patch_id + real(wp), dimension(1:3) :: xyz_local, center, offset !< x, y, z coordinates in local IB frame + real(wp), dimension(1:3, 1:3) :: inverse_rotation center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) @@ -422,12 +427,12 @@ contains call get_bounding_indices(center(3) - ca_in, center(3) + ca_in, z_cc, ll, lr) $:GPU_PARALLEL_LOOP(private='[i, j, l, xyz_local, k, f]', copyin='[encoded_patch_id, center, inverse_rotation, offset, ma, & - & ca_in, airfoil_grid_u, airfoil_grid_l, z_min, z_max]', collapse=3) + & ca_in, airfoil_grid_u, airfoil_grid_l, z_min, z_max]', collapse=3) do l = ll, lr do j = jl, jr do i = il, ir xyz_local = [x_cc(i) - center(1), y_cc(j) - center(2), & - & z_cc(l) - center(3)] ! get coordinate frame centered on IB + & z_cc(l) - center(3)] ! get coordinate frame centered on IB xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates xyz_local = xyz_local - offset ! airfoils are a patch that require a centroid offset @@ -475,16 +480,18 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_3D_airfoil !> The rectangular patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock !! region, in alignment with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x- and y- coordinate directions are provided. Please note that the rectangular patch DOES NOT !! allow for the smoothing of its boundaries. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !! @param patch_id is the patch identifier + !! @param ib_markers Array to track patch ids + !! @param ib True if this patch is an immersed boundary subroutine s_ib_rectangle(patch_id, ib_markers, xp, yp) + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp !< integers containing the periodicity projection information @@ -496,6 +503,7 @@ contains real(wp), dimension(1:3, 1:3) :: inverse_rotation ! Transferring the rectangle's centroid and length information + center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) length(1) = patch_ib(patch_id)%length_x @@ -514,12 +522,11 @@ contains call get_bounding_indices(center(1) - corner_distance, center(1) + corner_distance, x_cc, il, ir) call get_bounding_indices(center(2) - corner_distance, center(2) + corner_distance, y_cc, jl, jr) - ! Checking whether the rectangle covers a particular cell in the - ! domain and verifying whether the current patch has the permission - ! to write to that cell. If both queries check out, the primitive - ! variables of the current patch are assigned to this cell. + ! Checking whether the rectangle covers a particular cell in the domain and verifying whether the current patch has the + ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to + ! this cell. $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', & - & copyin='[encoded_patch_id, center, length, inverse_rotation, x_cc, y_cc]', collapse=2) + & copyin='[encoded_patch_id, center, length, inverse_rotation, x_cc, y_cc]', collapse=2) do j = jl, jr do i = il, ir ! get the x and y coordinates in the local IB frame @@ -534,15 +541,17 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_rectangle !> The spherical patch is a 3D geometry that may be used, for example, in creating a bubble or a droplet. The patch geometry is !! well-defined when its centroid and radius are provided. Please note that the spherical patch DOES allow for the smoothing of !! its boundary. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !! @param patch_id is the patch identifier + !! @param ib_markers Array to track patch ids + !! @param ib True if this patch is an immersed boundary subroutine s_ib_sphere(patch_id, ib_markers, xp, yp, zp) + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information @@ -553,11 +562,11 @@ contains real(wp) :: radius real(wp), dimension(1:3) :: center - !! Variables to initialize the pressure field that corresponds to the - !! bubble-collapse test case found in Tiwari et al. (2013) + !! Variables to initialize the pressure field that corresponds to the bubble-collapse test case found in Tiwari et al. + !! (2013) + + ! Transferring spherical patch's radius, centroid, smoothing patch identity and smoothing coefficient information - ! Transferring spherical patch's radius, centroid, smoothing patch - ! identity and smoothing coefficient information center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) center(3) = patch_ib(patch_id)%z_centroid + real(zp, wp)*(z_domain%end - z_domain%beg) @@ -577,10 +586,8 @@ contains call get_bounding_indices(center(2) - radius, center(2) + radius, y_cc, jl, jr) call get_bounding_indices(center(3) - radius, center(3) + radius, z_cc, kl, kr) - ! Checking whether the sphere covers a particular cell in the domain - ! and verifying whether the current patch has permission to write to - ! that cell. If both queries check out, the primitive variables of - ! the current patch are assigned to this cell. + ! Checking whether the sphere covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. $:GPU_PARALLEL_LOOP(private='[i, j, k, cart_y, cart_z]', copyin='[encoded_patch_id, center, radius]', collapse=3) do k = kl, kr do j = jl, jr @@ -600,15 +607,17 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_sphere !> The cuboidal patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post-shock region, !! which is aligned with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x-, y- and z-coordinate directions are provided. Please notice that the cuboidal patch DOES NOT !! allow for the smearing of its boundaries. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids + !! @param patch_id is the patch identifier + !! @param ib_markers Array to track patch ids subroutine s_ib_cuboid(patch_id, ib_markers, xp, yp, zp) + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information @@ -619,6 +628,7 @@ contains real(wp) :: corner_distance ! Transferring the cuboid's centroid and length information + center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) center(3) = patch_ib(patch_id)%z_centroid + real(zp, wp)*(z_domain%end - z_domain%beg) @@ -642,12 +652,11 @@ contains call get_bounding_indices(center(2) - corner_distance, center(2) + corner_distance, y_cc, jl, jr) call get_bounding_indices(center(3) - corner_distance, center(3) + corner_distance, z_cc, kl, kr) - ! Checking whether the cuboid covers a particular cell in the domain - ! and verifying whether the current patch has permission to write to - ! to that cell. If both queries check out, the primitive variables - ! of the current patch are assigned to this cell. + ! Checking whether the cuboid covers a particular cell in the domain and verifying whether the current patch has permission + ! to write to to that cell. If both queries check out, the primitive variables of the current patch are assigned to this + ! cell. $:GPU_PARALLEL_LOOP(private='[i, j, k, xyz_local, cart_y, cart_z]', copyin='[encoded_patch_id, center, length, & - & inverse_rotation]', collapse=3) + & inverse_rotation]', collapse=3) do k = kl, kr do j = jl, jr do i = il, ir @@ -671,16 +680,18 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_cuboid !> The cylindrical patch is a 3D geometry that may be used, for example, in setting up a cylindrical solid boundary confinement, !! like a blood vessel. The geometry of this patch is well-defined when the centroid, the radius and the length along the !! cylinder's axis, parallel to the x-, y- or z-coordinate direction, are provided. Please note that the cylindrical patch DOES !! allow for the smoothing of its lateral boundary. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !! @param patch_id is the patch identifier + !! @param ib_markers Array to track patch ids + !! @param ib True if this patch is an immersed boundary subroutine s_ib_cylinder(patch_id, ib_markers, xp, yp, zp) + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information @@ -692,6 +703,7 @@ contains real(wp) :: corner_distance ! Transferring the cylindrical patch's centroid, length, radius, + center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) center(3) = patch_ib(patch_id)%z_centroid + real(zp, wp)*(z_domain%end - z_domain%beg) @@ -715,12 +727,11 @@ contains call get_bounding_indices(center(2) - corner_distance, center(2) + corner_distance, y_cc, jl, jr) call get_bounding_indices(center(3) - corner_distance, center(3) + corner_distance, z_cc, kl, kr) - ! Checking whether the cylinder covers a particular cell in the - ! domain and verifying whether the current patch has the permission - ! to write to that cell. If both queries check out, the primitive - ! variables of the current patch are assigned to this cell. + ! Checking whether the cylinder covers a particular cell in the domain and verifying whether the current patch has the + ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to + ! this cell. $:GPU_PARALLEL_LOOP(private='[i, j, k, xyz_local, cart_y, cart_z]', copyin='[encoded_patch_id, center, length, radius, & - & inverse_rotation]', collapse=3) + & inverse_rotation]', collapse=3) do k = kl, kr do j = jl, jr do i = il, ir @@ -746,10 +757,12 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_cylinder !> @brief Marks cells inside a 2D elliptical immersed boundary defined by semi-axis lengths and rotation. subroutine s_ib_ellipse(patch_id, ib_markers, xp, yp) + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp !< integers containing the periodicity projection information @@ -761,6 +774,7 @@ contains real(wp), dimension(1:3, 1:3) :: inverse_rotation ! Transferring the ellipse's centroid and length information + center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) ellipse_coeffs(1) = 0.5_wp*patch_ib(patch_id)%length_x @@ -778,10 +792,9 @@ contains call get_bounding_indices(center(1) - maxval(ellipse_coeffs)*2._wp, center(1) + maxval(ellipse_coeffs)*2._wp, x_cc, il, ir) call get_bounding_indices(center(2) - maxval(ellipse_coeffs)*2._wp, center(2) + maxval(ellipse_coeffs)*2._wp, y_cc, jl, jr) - ! Checking whether the ellipse covers a particular cell in the - ! domain + ! Checking whether the ellipse covers a particular cell in the domain $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', copyin='[encoded_patch_id, center, ellipse_coeffs, inverse_rotation, x_cc, & - & y_cc]', collapse=2) + & y_cc]', collapse=2) do j = jl, jr do i = il, ir ! get the x and y coordinates in the local IB frame @@ -796,12 +809,14 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_ellipse !> The STL patch is a 2D geometry that is imported from an STL file. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_model(patch_id, ib_markers, xp, yp) + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp !< integers containing the periodicity projection information @@ -841,8 +856,7 @@ contains bbox_min = 1e12 bbox_max = -1e12 - ! Enumerate all 8 corners of the local bounding box, - ! rotate to world space, track world-space AABB + ! Enumerate all 8 corners of the local bounding box, rotate to world space, track world-space AABB do cx = 1, 2 do cy = 1, 2 local_corner = [lx(cx), ly(cy), 0._wp] @@ -858,8 +872,8 @@ contains call get_bounding_indices(bbox_min(2), bbox_max(2), y_cc, jl, jr) $:GPU_PARALLEL_LOOP(private='[i, j, xy_local, eta]', & - & copyin='[patch_id, encoded_patch_id, center, inverse_rotation, offset, & - & spc, threshold]', collapse=2) + & copyin='[patch_id, encoded_patch_id, center, inverse_rotation, offset, & + & spc, threshold]', collapse=2) do i = il, ir do j = jl, jr xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] @@ -875,12 +889,14 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_model !> The STL patch is a 3D geometry that is imported from an STL file. !! @param patch_id is the patch identifier !! @param ib_markers Array to track patch ids subroutine s_ib_3d_model(patch_id, ib_markers, xp, yp, zp) + integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information @@ -924,8 +940,7 @@ contains bbox_min = 1e12 bbox_max = -1e12 - ! Enumerate all 8 corners of the local bounding box, - ! rotate to world space, track world-space AABB + ! Enumerate all 8 corners of the local bounding box, rotate to world space, track world-space AABB do cx = 1, 2 do cy = 1, 2 do cz = 1, 2 @@ -946,7 +961,7 @@ contains call get_bounding_indices(bbox_min(3), bbox_max(3), z_cc, kl, kr) $:GPU_PARALLEL_LOOP(private='[i, j, k, xyz_local, eta]', copyin='[patch_id, encoded_patch_id, center, inverse_rotation, & - & offset, spc, threshold]', collapse=3) + & offset, spc, threshold]', collapse=3) do i = il, ir do j = jl, jr do k = kl, kr @@ -963,16 +978,19 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_ib_3d_model !> Subroutine that computes a rotation matrix for converting to the rotating frame of the boundary subroutine s_update_ib_rotation_matrix(patch_id) + integer, intent(in) :: patch_id integer :: i real(wp), dimension(3, 3, 3) :: rotation real(wp) :: angle ! construct the x, y, and z rotation matrices + if (num_dims == 3) then ! also compute the x and y axes in 3D angle = patch_ib(patch_id)%angles(1) @@ -1000,44 +1018,52 @@ contains ! apply the z rotation to the xy rotation in 3D patch_ib(patch_id)%rotation_matrix(:,:) = matmul(patch_ib(patch_id)%rotation_matrix(:,:), rotation(3,:,:)) patch_ib(patch_id)%rotation_matrix_inverse(:,:) = matmul(transpose(rotation(3,:,:)), & - & patch_ib(patch_id)%rotation_matrix_inverse(:,:)) + & patch_ib(patch_id)%rotation_matrix_inverse(:,:)) else ! write out only the z rotation in 2D patch_ib(patch_id)%rotation_matrix(:,:) = rotation(3,:,:) patch_ib(patch_id)%rotation_matrix_inverse(:,:) = transpose(rotation(3,:,:)) end if + end subroutine s_update_ib_rotation_matrix !> @brief Converts cylindrical (r, theta) coordinates to Cartesian (y, z) and stores in module variables. subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: cyl_y, cyl_z cart_y = cyl_y*sin(cyl_z) cart_z = cyl_y*cos(cyl_z) + end subroutine s_convert_cylindrical_to_cartesian_coord !> @brief Converts a 3D cylindrical coordinate vector (x, r, theta) to Cartesian (x, y, z). pure function f_convert_cyl_to_cart(cyl) result(cart) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(1:3), intent(in) :: cyl real(wp), dimension(1:3) :: cart cart = (/cyl(1), cyl(2)*sin(cyl(3)), cyl(2)*cos(cyl(3))/) + end function f_convert_cyl_to_cart !> @brief Converts cylindrical coordinates (x, r) to the spherical azimuthal angle phi and stores in a module variable. subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: cyl_x, cyl_y sph_phi = atan(cyl_y/cyl_x) + end subroutine s_convert_cylindrical_to_spherical_coord subroutine get_bounding_indices(left_bound, right_bound, cell_centers, left_index, right_index) + real(wp), intent(in) :: left_bound, right_bound integer, intent(inout) :: left_index, right_index real(wp), dimension(-buff_size:), intent(in) :: cell_centers @@ -1072,10 +1098,12 @@ contains end if end do right_index = itr_right + end subroutine get_bounding_indices !> @brief encodes the patch id with a unique offset that contains information on how the IB marker wraps periodically subroutine s_encode_patch_periodicity(patch_id, x_periodicity, y_periodicity, z_periodicity, encoded_patch_id) + integer, intent(in) :: patch_id, x_periodicity, y_periodicity, z_periodicity integer, intent(out) :: encoded_patch_id integer :: temp_x_per, temp_y_per, temp_z_per, offset @@ -1088,10 +1116,12 @@ contains offset = (num_ibs + 1)*temp_x_per + 3*(num_ibs + 1)*temp_y_per + 9*(num_ibs + 1)*temp_z_per encoded_patch_id = patch_id + offset + end subroutine s_encode_patch_periodicity !> @brief decodes the encoded id to get out the original id and the way in which it is periodic subroutine s_decode_patch_periodicity(encoded_patch_id, patch_id, x_periodicity, y_periodicity, z_periodicity) + $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: encoded_patch_id @@ -1112,16 +1142,19 @@ contains x_periodicity = xp; if (xp == 2) x_periodicity = -1 y_periodicity = yp; if (yp == 2) y_periodicity = -1 z_periodicity = zp; if (zp == 2) z_periodicity = -1 + end subroutine s_decode_patch_periodicity !> @brief Determines if we should wrap periodically subroutine s_get_periodicities(xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper) + integer, intent(out) :: xp_lower, xp_upper, yp_lower, yp_upper integer, intent(out), optional :: zp_lower, zp_upper ! check domain wraps in x, y #:for X in [('x'), ('y')] ! check for periodicity + if (bc_${X}$%beg == BC_PERIODIC) then ${X}$p_lower = -1 ${X}$p_upper = 1 @@ -1142,6 +1175,7 @@ contains zp_upper = 0 end if end if + end subroutine s_get_periodicities !> Archimedes spiral function @@ -1149,6 +1183,7 @@ contains !! @param offset Thickness !! @param a Starting position pure elemental function f_r(myth, offset, a) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: myth, offset, a real(wp) :: b @@ -1158,5 +1193,7 @@ contains b = 2._wp*a/(2._wp*pi) f_r = a + b*myth + offset + end function f_r + end module m_ib_patches diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index bb2a034504..5f3368657c 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -7,12 +7,13 @@ !> @brief Ghost-node immersed boundary method: locates ghost/image points, computes interpolation coefficients, and corrects the !! flow state module m_ibm - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures use m_helper - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_constants use m_compute_levelset use m_ib_patches @@ -38,10 +39,12 @@ module m_ibm $:GPU_DECLARE(create='[num_gps]') #endif logical :: moving_immersed_boundary_flag + contains !> Allocates memory for the variables in the IBM module impure subroutine s_initialize_ibm_module() + if (p > 0) then @:ALLOCATE(ib_markers%sf(-buff_size:m+buff_size, -buff_size:n+buff_size, -buff_size:p+buff_size)) else @@ -53,10 +56,12 @@ contains @:ACC_SETUP_SFs(ib_markers) $:GPU_ENTER_DATA(copyin='[num_gps]') + end subroutine s_initialize_ibm_module !> Initializes the values of various IBM variables, such as ghost points and image points. impure subroutine s_ibm_setup() + integer :: i, j, k integer :: max_num_gps @@ -113,24 +118,26 @@ contains call s_compute_interpolation_coeffs(ghost_points) call nvtxEndRange + end subroutine s_ibm_setup !> Subroutine that updates the conservative variables at the ghost points !! @param pb_in Internal bubble pressure !! @param mv_in Mass of vapor in bubble subroutine s_ibm_correct_state(q_cons_vf, q_prim_vf, pb_in, mv_in) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Primitive Variables - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive Variables + + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Primitive Variables + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive Variables real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), optional, intent(inout) :: pb_in, mv_in - integer :: i, j, k, l, q, r !< Iterator variables - integer :: patch_id !< Patch ID of ghost point - real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables - real(wp), dimension(2) :: Re_K - real(wp) :: G_K - real(wp) :: qv_K - real(wp) :: pres_IP - real(wp), dimension(3) :: vel_IP, vel_norm_IP - real(wp) :: c_IP + integer :: i, j, k, l, q, r !< Iterator variables + integer :: patch_id !< Patch ID of ghost point + real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables + real(wp), dimension(2) :: Re_K + real(wp) :: G_K + real(wp) :: qv_K + real(wp) :: pres_IP + real(wp), dimension(3) :: vel_IP, vel_norm_IP + real(wp) :: c_IP #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: Gs real(wp), dimension(3) :: alpha_rho_IP, alpha_IP @@ -144,8 +151,7 @@ contains real(wp), dimension(nb*nmom) :: nmom_IP real(wp), dimension(nb*nnode) :: presb_IP, massv_IP #:endif - !! Primitive variables at the image point associated with a ghost point, - !! interpolated from surrounding fluid cells. + !! Primitive variables at the image point associated with a ghost point, interpolated from surrounding fluid cells. real(wp), dimension(3) :: norm !< Normal vector from GP to IP real(wp), dimension(3) :: physical_loc !< Physical loc of GP @@ -158,6 +164,7 @@ contains type(ghost_point) :: innerp ! set the Moving IBM interior conservative variables + $:GPU_PARALLEL_LOOP(private='[i, j, k, patch_id, rho]', copyin='[E_idx, momxb]', collapse=3) do l = 0, p do k = 0, n @@ -183,8 +190,8 @@ contains if (num_gps > 0) then $:GPU_PARALLEL_LOOP(private='[i, physical_loc, dyn_pres, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, vel_g, vel_norm_IP, & - & r_IP, v_IP, pb_IP, mv_IP, nmom_IP, presb_IP, massv_IP, rho, gamma, pi_inf, Re_K, G_K, Gs, gp, innerp, norm, buf, & - & radial_vector, rotation_velocity, j, k, l, q, qv_K, c_IP, nbub, patch_id]') + & r_IP, v_IP, pb_IP, mv_IP, nmom_IP, presb_IP, massv_IP, rho, gamma, pi_inf, Re_K, G_K, Gs, gp, & + & innerp, norm, buf, radial_vector, rotation_velocity, j, k, l, q, qv_K, c_IP, nbub, patch_id]') do i = 1, num_gps gp = ghost_points(i) j = gp%loc(1) @@ -202,13 +209,13 @@ contains ! Interpolate primitive variables at image point associated w/ GP if (bubbles_euler .and. .not. qbmm) then call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & - & pb_IP, mv_IP) + & pb_IP, mv_IP) else if (qbmm .and. polytropic) then call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & - & pb_IP, mv_IP, nmom_IP) + & pb_IP, mv_IP, nmom_IP) else if (qbmm .and. .not. polytropic) then call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, & - & pb_IP, mv_IP, nmom_IP, pb_in, mv_in, presb_IP, massv_IP) + & pb_IP, mv_IP, nmom_IP, pb_in, mv_in, presb_IP, massv_IP) else call s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP) end if @@ -236,8 +243,8 @@ contains ! Se the pressure inside a moving immersed boundary based upon the pressure of the image point. ! acceleration, and normal vector direction q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, & - & l) + pres_IP/(1._wp - 2._wp*abs(gp%levelset*alpha_rho_IP(q)/pres_IP)*dot_product(patch_ib(patch_id) & - & %force/patch_ib(patch_id)%mass, gp%levelset_norm)) + & l) + pres_IP/(1._wp - 2._wp*abs(gp%levelset*alpha_rho_IP(q)/pres_IP) & + & *dot_product(patch_ib(patch_id) %force/patch_ib(patch_id)%mass, gp%levelset_norm)) end do end if @@ -245,7 +252,7 @@ contains ! If in simulation, use acc mixture subroutines if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, alpha_rho_IP, Re_K, & - & G_K, Gs) + & G_K, Gs) else call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, alpha_rho_IP, Re_K) end if @@ -261,9 +268,9 @@ contains if (patch_ib(patch_id)%moving_ibm /= 0) then ! compute the linear velocity of the ghost point due to rotation radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, patch_ib(patch_id)%y_centroid, & - & patch_ib(patch_id)%z_centroid] + & patch_ib(patch_id)%z_centroid] call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), & - & radial_vector, rotation_velocity) + & radial_vector, rotation_velocity) ! add only the component of the IB's motion that is normal to the surface vel_g = vel_g + sum((patch_ib(patch_id)%vel + rotation_velocity)*norm)*norm @@ -275,11 +282,11 @@ contains else ! get the vector that points from the centroid to the ghost radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, patch_ib(patch_id)%y_centroid, & - & patch_ib(patch_id)%z_centroid] + & patch_ib(patch_id)%z_centroid] ! convert the angular velocity from the inertial reference frame to the fluids frame, then convert to linear ! velocity call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), & - & radial_vector, rotation_velocity) + & radial_vector, rotation_velocity) do q = 1, 3 ! if mibm is 1 or 2, then the boundary may be moving vel_g(q) = patch_ib(patch_id)%vel(q) ! add the linear velocity @@ -362,11 +369,13 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_ibm_correct_state !> Function that computes the image points for each ghost point !! @param ghost_points_in Ghost Points impure subroutine s_compute_image_points(ghost_points_in) + type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in real(wp) :: dist real(wp), dimension(3) :: norm @@ -447,11 +456,12 @@ contains print *, "y: ", y_cc(-buff_size), " to: ", y_cc(n + buff_size - 1) if (p /= 0) print *, "z: ", z_cc(-buff_size), " to: ", z_cc(p + buff_size - 1) print *, "Image point is located approximately ", & - & (ghost_points_in(q)%loc(dim) - ghost_points_in(q) %ip_loc(dim))/(s_cc(1) - s_cc(0)), & - & " grid cells away" + & (ghost_points_in(q)%loc(dim) - ghost_points_in(q) & + & %ip_loc(dim))/(s_cc(1) - s_cc(0)), & + & " grid cells away" print *, "Levelset ", dist, " and Norm: ", norm(:) print *, & - & "A short term fix may include increasing buff_size further in m_helper_basic (currently set to a minimum of 10)" + & "A short term fix may include increasing buff_size further in m_helper_basic (currently set to a minimum of 10)" #endif bounds_error = .true. end if @@ -469,10 +479,12 @@ contains $:END_GPU_PARALLEL_LOOP() if (bounds_error) error stop "Ghost Point and Image Point on Different Processors. Exiting" + end subroutine s_compute_image_points !> Subroutine that finds the number of ghost points, used for allocating memory. subroutine s_find_num_ghost_points(num_gps_out) + integer, intent(out) :: num_gps_out integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables integer :: num_gps_local !< local copies of the gp count to support GPU compute @@ -483,7 +495,7 @@ contains if (p == 0) gp_layers_z = 0 $:GPU_PARALLEL_LOOP(private='[i, j, k, ii, jj, kk, is_gp]', copy='[num_gps_local]', firstprivate='[gp_layers, & - & gp_layers_z]', collapse=3) + & gp_layers_z]', collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -512,10 +524,12 @@ contains $:END_GPU_PARALLEL_LOOP() num_gps_out = num_gps_local + end subroutine s_find_num_ghost_points !> Function that finds the ghost points subroutine s_find_ghost_points(ghost_points_in) + type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables integer :: xp, yp, zp !< periodicities @@ -529,7 +543,8 @@ contains if (p == 0) gp_layers_z = 0 $:GPU_PARALLEL_LOOP(private='[i, j, k, ii, jj, kk, is_gp, local_idx, patch_id, encoded_patch_id, xp, yp, zp]', & - & copyin='[count, count_i, x_domain, y_domain, z_domain]', firstprivate='[gp_layers, gp_layers_z]', collapse=3) + & copyin='[count, count_i, x_domain, y_domain, z_domain]', firstprivate='[gp_layers, gp_layers_z]', & + & collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -594,10 +609,12 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_find_ghost_points !> Function that computes the interpolation coefficients of image points subroutine s_compute_interpolation_coeffs(ghost_points_in) + type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in real(wp), dimension(2, 2, 2) :: dist real(wp), dimension(2, 2, 2) :: alpha @@ -607,6 +624,7 @@ contains type(ghost_point) :: gp integer :: q, i, j, k, ii, jj, kk !< Grid indexes and iterators integer :: patch_id + logical is_cell_center $:GPU_PARALLEL_LOOP(private='[q, i, j, k, ii, jj, kk, dist, buf, gp, interp_coeffs, eta, alpha, patch_id, is_cell_center]') @@ -631,8 +649,8 @@ contains else do kk = 0, 1 dist(1 + ii, 1 + jj, & - & 1 + kk) = sqrt((x_cc(i + ii) - gp%ip_loc(1))**2 + (y_cc(j + jj) - gp%ip_loc(2))**2 + (z_cc(k & - & + kk) - gp%ip_loc(3))**2) + & 1 + kk) = sqrt((x_cc(i + ii) - gp%ip_loc(1))**2 + (y_cc(j + jj) - gp%ip_loc(2))**2 + (z_cc(k & + & + kk) - gp%ip_loc(3))**2) end do end if end do @@ -698,6 +716,7 @@ contains ghost_points_in(q)%interp_coeffs = interp_coeffs end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_compute_interpolation_coeffs !> Function that uses the interpolation coefficients and the current state at the cell centers in order to estimate the state at @@ -720,14 +739,15 @@ contains !! @param presb_IP Bubble node pressure at image point !! @param massv_IP Bubble node vapor mass at image point subroutine s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, pb_IP, mv_IP, & + & nmom_IP, pb_in, mv_in, presb_IP, massv_IP) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !< Primitive Variables + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !< Primitive Variables real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(in) :: pb_in, mv_in - type(ghost_point), intent(in) :: gp - real(wp), intent(inout) :: pres_IP - real(wp), dimension(3), intent(inout) :: vel_IP - real(wp), intent(inout) :: c_IP + type(ghost_point), intent(in) :: gp + real(wp), intent(inout) :: pres_IP + real(wp), dimension(3), intent(inout) :: vel_IP + real(wp), intent(inout) :: c_IP #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3), intent(inout) :: alpha_IP, alpha_rho_IP #:else @@ -821,9 +841,9 @@ contains do q = 1, nb do l = 1, nnode presb_IP((q - 1)*nnode + l) = presb_IP((q - 1)*nnode + l) + coeff*real(pb_in(i, j, k, l, q), & - & kind=wp) + & kind=wp) massv_IP((q - 1)*nnode + l) = massv_IP((q - 1)*nnode + l) + coeff*real(mv_in(i, j, k, l, q), & - & kind=wp) + & kind=wp) end do end do end if @@ -831,11 +851,13 @@ contains end do end do end do + end subroutine s_interpolate_image_point !> Resets the current indexes of immersed boundaries and replaces them after updating !> the position of each moving immersed boundary impure subroutine s_update_mib(num_ibs) + integer, intent(in) :: num_ibs integer :: i, j, k, ierr, z_gp_layers @@ -876,19 +898,20 @@ contains call nvtxEndRange call nvtxEndRange + end subroutine s_update_mib !> @brief Computes pressure and viscous forces and torques on immersed bodies via a volume integration method. subroutine s_compute_ib_forces(q_prim_vf, fluid_pp) - ! real(wp), dimension(idwbuff(1)%beg:idwbuff(1)%end, & - ! idwbuff(2)%beg:idwbuff(2)%end, & - ! idwbuff(3)%beg:idwbuff(3)%end), intent(in) :: pressure + + ! real(wp), dimension(idwbuff(1)%beg:idwbuff(1)%end, & idwbuff(2)%beg:idwbuff(2)%end, & idwbuff(3)%beg:idwbuff(3)%end), + ! intent(in) :: pressure type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf type(physical_parameters), dimension(1:num_fluids), intent(in) :: fluid_pp integer :: gp_id, i, j, k, l, q, ib_idx, fluid_idx real(wp), dimension(num_ibs, 3) :: forces, torques real(wp), dimension(1:3, 1:3) :: viscous_stress_div, viscous_stress_div_1, & - & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations + & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations real(wp), dimension(1:3) :: local_force_contribution, radial_vector, local_torque_contribution, vel real(wp) :: cell_volume, dx, dy, dz, dynamic_viscosity #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -913,8 +936,9 @@ contains end if $:GPU_PARALLEL_LOOP(private='[ib_idx, fluid_idx, radial_vector, local_force_contribution, cell_volume, & - & local_torque_contribution, dynamic_viscosity, viscous_stress_div, viscous_stress_div_1, viscous_stress_div_2, dx, dy, & - & dz]', copy='[forces, torques]', copyin='[ib_markers, patch_ib, dynamic_viscosities]', collapse=3) + & local_torque_contribution, dynamic_viscosity, viscous_stress_div, viscous_stress_div_1, & + & viscous_stress_div_2, dx, dy, dz]', copy='[forces, torques]', copyin='[ib_markers, patch_ib, & + & dynamic_viscosities]', collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -923,10 +947,10 @@ contains ! get the vector pointing to the grid cell from the IB centroid if (num_dims == 3) then radial_vector = [x_cc(i), y_cc(j), z_cc(k)] - [patch_ib(ib_idx)%x_centroid, & - & patch_ib(ib_idx)%y_centroid, patch_ib(ib_idx)%z_centroid] + & patch_ib(ib_idx)%y_centroid, patch_ib(ib_idx)%z_centroid] else radial_vector = [x_cc(i), y_cc(j), 0._wp] - [patch_ib(ib_idx)%x_centroid, & - & patch_ib(ib_idx)%y_centroid, 0._wp] + & patch_ib(ib_idx)%y_centroid, 0._wp] end if dx = x_cc(i + 1) - x_cc(i) dy = y_cc(j + 1) - y_cc(j) @@ -936,16 +960,16 @@ contains ! Get the pressure contribution to force via a finite difference to compute the 2D components of the ! gradient of the pressure and cell volume local_force_contribution(1) = local_force_contribution(1) - (q_prim_vf(E_idx + fluid_idx)%sf(i + 1, & - & j, k) - q_prim_vf(E_idx + fluid_idx)%sf(i - 1, j, & - & k))/(2._wp*dx) ! force is the negative pressure gradient + & j, k) - q_prim_vf(E_idx + fluid_idx)%sf(i - 1, j, & + & k))/(2._wp*dx) ! force is the negative pressure gradient local_force_contribution(2) = local_force_contribution(2) - (q_prim_vf(E_idx + fluid_idx)%sf(i, & - & j + 1, k) - q_prim_vf(E_idx + fluid_idx)%sf(i, j - 1, k))/(2._wp*dy) + & j + 1, k) - q_prim_vf(E_idx + fluid_idx)%sf(i, j - 1, k))/(2._wp*dy) cell_volume = abs(dx*dy) ! add the 3D component of the pressure gradient, if we are working in 3 dimensions if (num_dims == 3) then dz = z_cc(k + 1) - z_cc(k) local_force_contribution(3) = local_force_contribution(3) - (q_prim_vf(E_idx + fluid_idx)%sf(i, & - & j, k + 1) - q_prim_vf(E_idx + fluid_idx)%sf(i, j, k - 1))/(2._wp*dz) + & j, k + 1) - q_prim_vf(E_idx + fluid_idx)%sf(i, j, k - 1))/(2._wp*dz) cell_volume = abs(cell_volume*dz) end if end do @@ -957,33 +981,33 @@ contains do fluid_idx = 1, num_fluids ! local dynamic viscosity is the dynamic viscosity of the fluid times alpha of the fluid dynamic_viscosity = dynamic_viscosity + (q_prim_vf(fluid_idx + advxb - 1)%sf(i, j, & - & k)*dynamic_viscosities(fluid_idx)) + & k)*dynamic_viscosities(fluid_idx)) end do ! get the linear force components first call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i - 1, j, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i + 1, j, k) viscous_stress_div(1, 1:3) = (viscous_stress_div_2(1, 1:3) - viscous_stress_div_1(1, & - & 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor + & 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(1, & - & 1:3) ! add the x components of the divergence to the force + & 1:3) ! add the x components of the divergence to the force call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j - 1, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j + 1, k) viscous_stress_div(2, 1:3) = (viscous_stress_div_2(2, 1:3) - viscous_stress_div_1(2, & - & 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor + & 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(2, & - & 1:3) ! add the y components of the divergence to the force + & 1:3) ! add the y components of the divergence to the force if (num_dims == 3) then call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j, & - & k - 1) + & k - 1) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j, & - & k + 1) + & k + 1) viscous_stress_div(3, 1:3) = (viscous_stress_div_2(3, 1:3) - viscous_stress_div_1(3, & - & 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor + & 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(3, & - & 1:3) ! add the z components of the divergence to the force + & 1:3) ! add the z components of the divergence to the force end if end if @@ -1023,29 +1047,34 @@ contains do i = 1, num_ibs patch_ib(i)%force(:) = forces(i,:) patch_ib(i)%torque(:) = matmul(patch_ib(i)%rotation_matrix_inverse, torques(i, & - & :)) ! torques must be converted to the local coordinates of the IB + & :)) ! torques must be converted to the local coordinates of the IB end do call nvtxEndRange + end subroutine s_compute_ib_forces !> Subroutine to deallocate memory reserved for the IBM module impure subroutine s_finalize_ibm_module() + @:DEALLOCATE(ib_markers%sf) if (allocated(airfoil_grid_u)) then @:DEALLOCATE(airfoil_grid_u) @:DEALLOCATE(airfoil_grid_l) end if + end subroutine s_finalize_ibm_module !> Computes the center of mass for IB patch types where we are unable to determine their center of mass analytically. !> These patches include things like NACA airfoils and STL models subroutine s_compute_centroid_offset(ib_marker) + integer, intent(in) :: ib_marker integer :: i, j, k, num_cells, num_cells_local real(wp), dimension(1:3) :: center_of_mass, center_of_mass_local ! Offset only needs to be computes for specific geometries + if (patch_ib(ib_marker)%geometry == 4 .or. patch_ib(ib_marker)%geometry == 5 .or. patch_ib(ib_marker) & & %geometry == 11 .or. patch_ib(ib_marker)%geometry == 12) then center_of_mass_local = [0._wp, 0._wp, 0._wp] @@ -1079,22 +1108,24 @@ contains ! assign the centroid offset as a vector pointing from the true COM to the "centroid" in the input file and replace the ! current centroid patch_ib(ib_marker)%centroid_offset = [patch_ib(ib_marker)%x_centroid, patch_ib(ib_marker)%y_centroid, & - & patch_ib(ib_marker)%z_centroid] - center_of_mass + & patch_ib(ib_marker)%z_centroid] - center_of_mass patch_ib(ib_marker)%x_centroid = center_of_mass(1) patch_ib(ib_marker)%y_centroid = center_of_mass(2) patch_ib(ib_marker)%z_centroid = center_of_mass(3) ! rotate the centroid offset back into the local coords of the IB patch_ib(ib_marker)%centroid_offset = matmul(patch_ib(ib_marker)%rotation_matrix_inverse, & - & patch_ib(ib_marker)%centroid_offset) + & patch_ib(ib_marker)%centroid_offset) else patch_ib(ib_marker)%centroid_offset(:) = [0._wp, 0._wp, 0._wp] end if + end subroutine s_compute_centroid_offset !> Computes the moment of inertia for an immersed boundary !! @param ib_marker Immersed boundary marker index subroutine s_compute_moment_of_inertia(ib_marker, axis) + real(wp), dimension(3), intent(in) :: axis !< the axis about which we compute the moment. Only required in 3D. integer, intent(in) :: ib_marker real(wp) :: moment, distance_to_axis, cell_volume @@ -1116,23 +1147,23 @@ contains patch_ib(ib_marker)%moment = 0.5_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%radius)**2 else if (patch_ib(ib_marker)%geometry == 3) then ! rectangle patch_ib(ib_marker)%moment = patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker) & - & %length_y**2)/6._wp + & %length_y**2)/6._wp else if (patch_ib(ib_marker)%geometry == 6) then ! ellipse patch_ib(ib_marker)%moment = 0.0625_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker) & - & %length_y**2) + & %length_y**2) else if (patch_ib(ib_marker)%geometry == 8) then ! sphere patch_ib(ib_marker)%moment = 0.4*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%radius)**2 else ! we do not have an analytic moment of inertia calculation and need to approximate it directly via a sum count = 0 moment = 0._wp cell_volume = (x_cc(1) - x_cc(0))*(y_cc(1) - y_cc(0)) & - & ! computed without grid stretching. Update in the loop to perform with stretching + & ! computed without grid stretching. Update in the loop to perform with stretching if (p /= 0) then cell_volume = cell_volume*(z_cc(1) - z_cc(0)) end if $:GPU_PARALLEL_LOOP(private='[position, closest_point_along_axis, vector_to_axis, distance_to_axis]', copy='[moment, & - & count]', copyin='[ib_marker, cell_volume, normal_axis]', collapse=3) + & count]', copyin='[ib_marker, cell_volume, normal_axis]', collapse=3) do i = 0, m do j = 0, n do k = 0, p @@ -1143,10 +1174,10 @@ contains ! get the position in local coordinates so that the axis passes through 0, 0, 0 if (p == 0) then position = [x_cc(i), y_cc(j), 0._wp] - [patch_ib(ib_marker)%x_centroid, & - & patch_ib(ib_marker)%y_centroid, 0._wp] + & patch_ib(ib_marker)%y_centroid, 0._wp] else position = [x_cc(i), y_cc(j), z_cc(k)] - [patch_ib(ib_marker)%x_centroid, & - & patch_ib(ib_marker)%y_centroid, patch_ib(ib_marker)%z_centroid] + & patch_ib(ib_marker)%y_centroid, patch_ib(ib_marker)%z_centroid] end if ! project the position along the axis to find the closest distance to the rotation axis @@ -1167,10 +1198,12 @@ contains patch_ib(ib_marker)%moment = moment*patch_ib(ib_marker)%mass/(count*cell_volume) $:GPU_UPDATE(device='[patch_ib(ib_marker)%moment]') end if + end subroutine s_compute_moment_of_inertia !> @brief Checks for periodic boundary conditions in all directions, and if so, moves patch location if it left the domain subroutine s_wrap_periodic_ibs() + integer :: patch_id do patch_id = 1, num_ibs @@ -1182,11 +1215,11 @@ contains if (patch_ib(patch_id)%${X}$_centroid < ${X}$_domain%beg) then ! if the boundary exited "left", wrap it back around to the "right" patch_ib(patch_id)%${X}$_centroid = patch_ib(patch_id)%${X}$_centroid + (${X}$_domain%end & - & - ${X}$_domain%beg) + & - ${X}$_domain%beg) else if (patch_ib(patch_id)%${X}$_centroid > ${X}$_domain%end) then ! if the boundary exited "right", wrap it back around to the "left" patch_ib(patch_id)%${X}$_centroid = patch_ib(patch_id)%${X}$_centroid - (${X}$_domain%end & - & - ${X}$_domain%beg) + & - ${X}$_domain%beg) end if end if #:endfor @@ -1205,10 +1238,12 @@ contains end if end if end do + end subroutine s_wrap_periodic_ibs !> @brief Computes the cross product c = a x b of two 3D vectors. subroutine s_cross_product(a, b, c) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: a(3), b(3) real(wp), intent(out) :: c(3) @@ -1216,5 +1251,7 @@ contains c(1) = a(2)*b(3) - a(3)*b(2) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) + end subroutine s_cross_product + end module m_ibm diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index f989eb76d2..3bd3a19d8f 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -7,6 +7,7 @@ !> @brief Iterative ghost rasterization (IGR) for sharp immersed boundary treatment module m_igr + use m_derived_types !< Definitions of the derived types use m_global_parameters use m_variables_conversion @@ -80,11 +81,13 @@ module m_igr #:endif integer(kind=8) :: i, j, k, l, q, r + contains !> @brief Allocates and initializes arrays, coefficients, and GPU data structures for the implicit gradient reconstruction !! module. subroutine s_initialize_igr_module() + if (viscous) then @:ALLOCATE(Res_igr(1:2, 1:maxval(Re_size))) do i = 1, 2 @@ -134,7 +137,7 @@ contains allocate (jac_old_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => jac_old_host(:,:,:) + & idwbuff(3)%beg:idwbuff(3)%end) => jac_old_host(:,:,:) end if end if #endif @@ -201,10 +204,12 @@ contains jac_sf(1)%sf => jac $:GPU_ENTER_DATA(copyin='[jac_sf(1)%sf]') $:GPU_ENTER_DATA(attach='[jac_sf(1)%sf]') + end subroutine s_initialize_igr_module !> @brief Iteratively solves the implicit gradient reconstruction system using Jacobi or Gauss-Seidel relaxation. subroutine s_igr_iterative_solve(q_cons_vf, bc_type, t_step) + #ifdef _CRAYFTN ! DIR$ OPTIMIZE (-haggress) #endif @@ -248,7 +253,7 @@ contains end do fd_coeff = 1._wp/fd_coeff + alf_igr*((1._wp/dx(j)**2._wp)*(1._wp/rho_lx + 1._wp/rho_rx) + (1._wp/dy(k) & - & **2._wp)*(1._wp/rho_ly + 1._wp/rho_ry)) + & **2._wp)*(1._wp/rho_ly + 1._wp/rho_ry)) if (num_dims == 3) then fd_coeff = fd_coeff + alf_igr*(1._wp/dz(l)**2._wp)*(1._wp/rho_lz + 1._wp/rho_rz) @@ -300,10 +305,12 @@ contains $:END_GPU_PARALLEL_LOOP() end if end do + end subroutine s_igr_iterative_solve !> @brief Computes the IGR viscous stress contribution in the x-direction and accumulates it into the RHS. subroutine s_igr_sigma_x(q_cons_vf, rhs_vf) + #ifdef _CRAYFTN ! DIR$ OPTIMIZE (-haggress) #endif @@ -364,24 +371,26 @@ contains #:for LR in ['L', 'R'] $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) + & l) + real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) + & l) + real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, l) - real(0.5_wp*dt*F_${LR}$*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, l) - real(0.5_wp*dt*vel_${LR}$*F_${LR}$*(1._wp/dx(j)), & - & kind=stp) + & kind=stp) #:endfor end do end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_igr_sigma_x !> @brief Evaluates the approximate Riemann solver for the IGR scheme along a given coordinate direction. subroutine s_igr_riemann_solver(q_cons_vf, rhs_vf, idir) + #ifdef _CRAYFTN ! DIR$ OPTIMIZE (-haggress) #endif @@ -409,8 +418,9 @@ contains if (p == 0) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & - & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, & - & dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, & + & F_R, & + & E_L, E_R, cfl, dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = 0, n do j = -1, m @@ -438,9 +448,9 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(1._wp*q_cons_vf(momxb)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - 1._wp*q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - 1._wp*q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -470,9 +480,9 @@ contains end do dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j + q, k + 1, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j + q, k + 1, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -492,7 +502,7 @@ contains if (q == 0) then jac_rhs(j, k, l) = real(alf_igr*(2._wp*(dvel(1, 2)*dvel(2, 1)) + dvel(1, & - & 1)**2._wp + dvel(2, 2)**2._wp + (dvel(1, 1) + dvel(2, 2))**2._wp), kind=stp) + & 1)**2._wp + dvel(2, 2)**2._wp + (dvel(1, 1) + dvel(2, 2))**2._wp), kind=stp) end if end do @@ -595,59 +605,59 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -663,18 +673,18 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & - & vel_R, pres_L, pres_R, cfl) + & vel_R, pres_L, pres_R, cfl) do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then @@ -682,67 +692,67 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & - & l)*vel_L(1)*(1._wp/dx(j + 1))), kind=stp) + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_L(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(alpha_L(i) & - & )*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j))), & - & kind=stp) + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l)*vel_L(1)*(1._wp/dx(j))), kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j))), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then @@ -750,55 +760,55 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & - & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(alpha_R(i) & - & )*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(1)*(1._wp/dx(j))), & - & kind=stp) + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l)*vel_R(1)*(1._wp/dx(j))), kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j))), kind=stp) end do end do end do @@ -807,8 +817,9 @@ contains else #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & - & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, & - & dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, & + & F_R, & + & E_L, E_R, cfl, dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = 0, n do j = -1, m @@ -836,11 +847,11 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 2)%sf(j + 1 + q, k, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1 + q, k, l)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') @@ -872,9 +883,9 @@ contains end do dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j + q, k + 1, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k - 1, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j + q, k + 1, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k - 1, l)/rho_sf_small(-1)) if (q == 0) dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j + q, k + 1, & & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j + q, k - 1, l)/rho_sf_small(-1)) if (q == 0) then @@ -905,11 +916,11 @@ contains end do dvel_small(1) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb)%sf(j + q, k, & - & l + 1)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k, l - 1)/rho_sf_small(-1)) + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j + q, k, l - 1)/rho_sf_small(-1)) if (q == 0) dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j + q, k, & & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j + q, k, l - 1)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j + q, k, & - & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j + q, k, l - 1)/rho_sf_small(-1)) + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j + q, k, l - 1)/rho_sf_small(-1)) if (q == 0) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -928,8 +939,8 @@ contains if (q == 0) then jac_rhs(j, k, l) = real(alf_igr*(2._wp*(dvel(1, 2)*dvel(2, 1) + dvel(1, 3)*dvel(3, & - & 1) + dvel(2, 3)*dvel(3, 2)) + dvel(1, 1)**2._wp + dvel(2, 2)**2._wp + dvel(3, & - & 3)**2._wp + (dvel(1, 1) + dvel(2, 2) + dvel(3, 3))**2._wp), kind=stp) + & 1) + dvel(2, 3)*dvel(3, 2)) + dvel(1, 1)**2._wp + dvel(2, 2)**2._wp + dvel(3, & + & 3)**2._wp + (dvel(1, 1) + dvel(2, 2) + dvel(3, 3))**2._wp), kind=stp) end if end do @@ -1033,87 +1044,87 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(1)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(1)*(1._wp/dx(j)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -1129,19 +1140,19 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & - & vel_R, pres_L, pres_R, cfl) + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_rho_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then @@ -1149,77 +1160,77 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & - & l)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_L(1)*(1._wp/dx(j + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(alpha_L(i)) & - & *(1._wp/dx(j)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(1))*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dx(j)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(1)*(1._wp/dx(j)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j + 1)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(rho_L*(vel_L(1))**2.0 + pres_L)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(rho_L*vel_L(3)) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dx(j)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(vel_L(1)*(E_L + pres_L))*(1._wp/dx(j)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dx(j))), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j + 1, k, l) = rhs_vf(i)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_rho_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dx(j))), kind=stp) end do if (num_fluids > 1) then @@ -1227,65 +1238,65 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j + 1, k, l) = rhs_vf(advxb + i - 1)%sf(j + 1, k, & - & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & - & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) + & l) - real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j + 1, k, & + & l)*vel_R(1)*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(alpha_R(i) & - & )*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(alpha_R(i)*vel_R(1))*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(1)*(1._wp/dx(j))), & - & kind=stp) + & l) + real((0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l)*vel_R(1)*(1._wp/dx(j))), kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j + 1, k, l) = rhs_vf(momxb)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j + 1, k, l) = rhs_vf(momxb + 1)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j + 1, k, l) = rhs_vf(momxb + 2)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j + 1, k, l) = rhs_vf(E_idx)%sf(j + 1, k, & - & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dx(j + 1))), kind=stp) + & l) + real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j + 1)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j + 1))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(rho_R*(vel_R(1))**2.0 + pres_R)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(2)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(rho_R*vel_R(3)) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dx(j)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dx(j))), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dx(j))), kind=stp) + & l) - real((0.5_wp*dt*(vel_R(1)*(E_R + pres_R))*(1._wp/dx(j)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dx(j))), kind=stp) end do end do end do @@ -1296,8 +1307,9 @@ contains if (p == 0) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & - & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, & - & dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, & + & F_R, & + & E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = -1, n do j = 0, m @@ -1326,9 +1338,9 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1, k + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(2)) @@ -1351,9 +1363,9 @@ contains end do dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) @@ -1466,59 +1478,59 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -1537,19 +1549,19 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & - & vel_R, pres_L, pres_R, cfl) + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then @@ -1557,66 +1569,66 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & - & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(alpha_L(i)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dy(k)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then @@ -1624,49 +1636,49 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & - & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(alpha_R(i)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dy(k)), kind=stp) end do end do end do @@ -1675,8 +1687,9 @@ contains else #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & - & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, & - & dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, & + & F_R, & + & E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = -1, n do j = 0, m @@ -1705,9 +1718,9 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k + q, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 1)%sf(j + 1, k + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j - 1, k + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(2)) @@ -1730,11 +1743,11 @@ contains end do dvel_small(1) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j, k + 1 + q, & - & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) + & l)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1 + q, l)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) @@ -1759,9 +1772,11 @@ contains end do dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j, k + q, & - & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k + q, l - 1)/rho_sf_small(-1)) + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k + q, & + & l - 1)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j, k + q, & - & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k + q, l - 1)/rho_sf_small(-1)) + & l + 1)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k + q, & + & l - 1)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(2)) vflux_L_arr(3) = vflux_L_arr(3) + coeff_L(q)*(-2._wp*dvel_small(3))/3._wp @@ -1873,87 +1888,87 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(2)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(2)*(1._wp/dy(k)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -1972,19 +1987,19 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, & - & vel_R, pres_L, pres_R, cfl) + & vel_R, pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then @@ -1992,77 +2007,77 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & - & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_L(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(alpha_L(i)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(2))*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k + 1)) & + & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(rho_L*(vel_L(2))**2.0 + pres_L + F_L)*(1._wp/dy(k)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(3)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(3)*vel_L(2)*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(rho_L*vel_L(3) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(vel_L(2)*(E_L + pres_L + F_L))*(1._wp/dy(k)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dy(k)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k + 1, l) = rhs_vf(i)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dy(k)), kind=stp) end do if (num_fluids > 1) then @@ -2070,65 +2085,65 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k + 1, l) = rhs_vf(advxb + i - 1)%sf(j, k + 1, & - & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & - & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) + & l) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k + 1, & + & l)*vel_R(2)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(alpha_R(i)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(2))*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & - & kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(2)*(1._wp/dy(k)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k + 1, l) = rhs_vf(momxb + 1)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k + 1, l) = rhs_vf(momxb)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k + 1, l) = rhs_vf(momxb + 2)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k + 1, l) = rhs_vf(E_idx)%sf(j, k + 1, & - & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dy(k + 1)), kind=stp) + & l) + real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k + 1)) & + & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dy(k + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(rho_R*(vel_R(2))**2.0 + pres_R + F_R)*(1._wp/dy(k)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(1)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(3)) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(rho_R*vel_R(3) & + & )*(1._wp/dy(k)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dy(k)), kind=stp) + & l) - real(0.5_wp*dt*(vel_R(2)*(E_R + pres_R + F_R))*(1._wp/dy(k)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dy(k)), kind=stp) end do end do end do @@ -2138,8 +2153,9 @@ contains else if (idir == 3) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, mu_R, & - & vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, E_R, cfl, dvel_small, & - & rho_sf_small, vflux_L_arr, vflux_R_arr]') + & vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, & + & E_R, & + & cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = -1, p do k = 0, n do j = 0, m @@ -2168,9 +2184,9 @@ contains end do dvel_small(1) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb)%sf(j + 1, k, & - & l + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k, l + q)/rho_sf_small(-1)) + & l + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j - 1, k, l + q)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dx(j)))*(q_cons_vf(momxb + 2)%sf(j + 1, k, & - & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1, k, l + q)/rho_sf_small(-1)) + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j - 1, k, l + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(3)) @@ -2193,9 +2209,9 @@ contains end do dvel_small(2) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 1)%sf(j, k + 1, & - & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1, l + q)/rho_sf_small(-1)) + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k - 1, l + q)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dy(k)))*(q_cons_vf(momxb + 2)%sf(j, k + 1, & - & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1, l + q)/rho_sf_small(-1)) + & l + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k - 1, l + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(3)) @@ -2217,11 +2233,13 @@ contains rho_sf_small(i) = rho_L end do dvel_small(1) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb)%sf(j, k, & - & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) dvel_small(2) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 1)%sf(j, k, & - & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 1)%sf(j, k, & + & l - 1 + q)/rho_sf_small(-1)) dvel_small(3) = (1/(2._wp*dz(l)))*(q_cons_vf(momxb + 2)%sf(j, k, & - & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k, l - 1 + q)/rho_sf_small(-1)) + & l + 1 + q)/rho_sf_small(1) - q_cons_vf(momxb + 2)%sf(j, k, & + & l - 1 + q)/rho_sf_small(-1)) if (q > vidxb) then vflux_L_arr(1) = vflux_L_arr(1) + coeff_L(q)*(dvel_small(1)) vflux_L_arr(2) = vflux_L_arr(2) + coeff_L(q)*(dvel_small(2)) @@ -2336,87 +2354,87 @@ contains $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(1)*vel_L(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(1)*vel_R(1)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(2)*vel_L(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(2)*vel_R(2)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_L*vflux_L_arr(3)*vel_L(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*mu_R*vflux_R_arr(3)*vel_R(3)*(1._wp/dz(l)), kind=stp) end if E_L = 0._wp; E_R = 0._wp @@ -2435,19 +2453,19 @@ contains end do call s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, vel_R, & - & pres_L, pres_R, cfl) + & pres_L, pres_R, cfl) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l + 1) = rhs_vf(i)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(alpha_rho_L(i)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_L(i)*vel_L(3))*(1._wp/dz(l)) & + & - 0.5_wp*dt*cfl*(alpha_rho_L(i))*(1._wp/dz(l)), kind=stp) end do if (num_fluids > 1) then @@ -2455,76 +2473,77 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(alpha_L(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & - & l + 1)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l + 1)*vel_L(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(alpha_L(i)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_L(i)*vel_L(3))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(alpha_L(i)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_L(3)*(1._wp/dz(l)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(1))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l + 1)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(2))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l + 1)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l + 1)) & + & - 0.5_wp*dt*cfl*(E_L)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l)) & - & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(rho_L*(vel_L(3))**2.0 + pres_L + F_L)*(1._wp/dz(l)) & + & - 0.5_wp*dt*cfl*(rho_L*vel_L(3))*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(1)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(1)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*rho_L*vel_L(2)*vel_L(3)*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(rho_L*vel_L(2)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(E_L) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(vel_L(3)*(E_L + pres_L + F_L))*(1._wp/dz(l)) - 0.5_wp*dt*cfl*(E_L) & + & *(1._wp/dz(l)), kind=stp) $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l + 1) = rhs_vf(i)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(alpha_rho_R(i)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_rho_R(i)*vel_R(3))*(1._wp/dz(l)) & + & + 0.5_wp*dt*cfl*(alpha_rho_R(i))*(1._wp/dz(l)), kind=stp) end do if (num_fluids > 1) then @@ -2532,74 +2551,77 @@ contains do i = 1, num_fluids - 1 $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(alpha_R(i))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l + 1) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & - & l + 1)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) + & l + 1) - real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, & + & l + 1)*vel_R(3)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(alpha_R(i)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(alpha_R(i)*vel_R(3))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(alpha_R(i)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(advxb + i - 1)%sf(j, k, l) = rhs_vf(advxb + i - 1)%sf(j, k, & - & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(3)*(1._wp/dz(l)), kind=stp) + & l) + real(0.5_wp*dt*q_cons_vf(advxb + i - 1)%sf(j, k, l)*vel_R(3)*(1._wp/dz(l)), & + & kind=stp) end do end if $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l + 1) = rhs_vf(momxb + 2)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l + 1) = rhs_vf(momxb)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(1))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l + 1) = rhs_vf(momxb + 1)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l + 1)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(2))*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l + 1) = rhs_vf(E_idx)%sf(j, k, & - & l + 1) + real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l + 1)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dz(l + 1)), kind=stp) + & l + 1) + real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l + 1)) & + & + 0.5_wp*dt*cfl*(E_R)*(1._wp/dz(l + 1)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 2)%sf(j, k, l) = rhs_vf(momxb + 2)%sf(j, k, & - & l) - real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l)) & - & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(rho_R*(vel_R(3))**2.0 + pres_R + F_R)*(1._wp/dz(l)) & + & + 0.5_wp*dt*cfl*(rho_R*vel_R(3))*(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb)%sf(j, k, l) = rhs_vf(momxb)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(1)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(1)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, & - & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*rho_R*vel_R(2)*vel_R(3)*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(rho_R*vel_R(2)) & + & *(1._wp/dz(l)), kind=stp) $:GPU_ATOMIC(atomic='update') rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) - real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(E_R) & - & *(1._wp/dz(l)), kind=stp) + & l) - real(0.5_wp*dt*(vel_R(3)*(E_R + pres_R + F_R))*(1._wp/dz(l)) + 0.5_wp*dt*cfl*(E_R) & + & *(1._wp/dz(l)), kind=stp) end do end do end do $:END_GPU_PARALLEL_LOOP() #:endif end if + end subroutine s_igr_riemann_solver !> @brief Computes pressure and maximum wavespeed from left and right reconstructed states for the IGR Riemann solver. subroutine s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, vel_R, pres_L, pres_R, cfl) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: E_L, gamma_L, pi_inf_L, rho_L @@ -2635,13 +2657,15 @@ contains a_R = sqrt((pres_R*(1._wp/gamma_R + 1._wp) + pi_inf_R/gamma_R)/rho_R) cfl = max(sqrt(vel_L(1)**2._wp + vel_L(2)**2._wp + vel_L(3)**2._wp), & - & sqrt(vel_R(1)**2._wp + vel_R(2)**2._wp + vel_R(3)**2._wp)) + max(a_L, a_R) + & sqrt(vel_R(1)**2._wp + vel_R(2)**2._wp + vel_R(3)**2._wp)) + max(a_L, a_R) #:endif end if + end subroutine s_get_derived_states !> @brief Accumulates the IGR numerical flux divergence into the right-hand side along the specified coordinate direction. subroutine s_igr_flux_add(q_cons_vf, rhs_vf, flux_vf, idir) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, flux_vf, rhs_vf integer, intent(in) :: idir @@ -2664,7 +2688,7 @@ contains do k = 0, n do j = 0, m rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_vf(i)%sf(j, k - 1, & - & l) - flux_vf(i)%sf(j, k, l)) + & l) - flux_vf(i)%sf(j, k, l)) end do end do end do @@ -2677,17 +2701,19 @@ contains do k = 0, n do j = 0, m rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_vf(i)%sf(j, k, & - & l - 1) - flux_vf(i)%sf(j, k, l)) + & l - 1) - flux_vf(i)%sf(j, k, l)) end do end do end do end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_igr_flux_add !> @brief Deallocates all arrays and GPU resources allocated by the IGR module. subroutine s_finalize_igr_module() + if (viscous) then @:DEALLOCATE(Res_igr) end if @@ -2726,5 +2752,7 @@ contains #:if not MFC_CASE_OPTIMIZATION @:DEALLOCATE(coeff_L, coeff_R) #:endif + end subroutine s_finalize_igr_module + end module m_igr diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index c229e9fd6f..ff0587c9c3 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -7,13 +7,14 @@ !> @brief MPI halo exchange, domain decomposition, and buffer packing/unpacking for the simulation solver module m_mpi_proxy + #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper - use m_derived_types !< Definitions of the derived types + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_mpi_common use m_nvtx @@ -29,16 +30,18 @@ module m_mpi_proxy integer, private, allocatable, dimension(:) :: ib_buff_recv integer :: i_halo_size $:GPU_DECLARE(create='[i_halo_size]') + contains !> @brief Allocates immersed boundary communication buffers for MPI halo exchanges. subroutine s_initialize_mpi_proxy_module() + #ifdef MFC_MPI if (ib) then if (n > 0) then if (p > 0) then i_halo_size = -1 + buff_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)*(p + 2*buff_size + 1) & - & /(cells_bounds%mnp_min + 2*buff_size + 1) + & /(cells_bounds%mnp_min + 2*buff_size + 1) else i_halo_size = -1 + buff_size*(cells_bounds%mn_max + 2*buff_size + 1) end if @@ -50,16 +53,19 @@ contains @:ALLOCATE(ib_buff_send(0:i_halo_size), ib_buff_recv(0:i_halo_size)) end if #endif + end subroutine s_initialize_mpi_proxy_module !> Since only the processor with rank 0 reads and verifies the consistency of user inputs, these are initially not available to !! the other processors. Then, the purpose of this subroutine is to distribute the user inputs to the remaining processors in !! the communicator. impure subroutine s_mpi_bcast_user_inputs() + #ifdef MFC_MPI integer :: i, j !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors + call MPI_BCAST(case_dir, len(case_dir), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) #:for VAR in ['k_x', 'k_y', 'k_z', 'w_x', 'w_y', 'w_z', 'p_x', 'p_y', & @@ -233,25 +239,32 @@ contains call MPI_BCAST(nv_uvm_igr_temps_on_gpu, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(nv_uvm_pref_gpu, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_bcast_user_inputs !> @brief Broadcasts random phase numbers from rank 0 to all MPI processes. impure subroutine s_mpi_send_random_number(phi_rn, num_freq) + integer, intent(in) :: num_freq real(wp), intent(inout), dimension(1:num_freq) :: phi_rn #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors + call MPI_BCAST(phi_rn, num_freq, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif + end subroutine s_mpi_send_random_number !> @brief Deallocates immersed boundary MPI communication buffers. subroutine s_finalize_mpi_proxy_module() + #ifdef MFC_MPI if (ib) then @:DEALLOCATE(ib_buff_send, ib_buff_recv) end if #endif + end subroutine s_finalize_mpi_proxy_module + end module m_mpi_proxy diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index 735b14afd7..f7d4e23cbe 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -6,8 +6,9 @@ !> @brief MUSCL reconstruction with interface sharpening for contact-preserving advection module m_muscl - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion !< State variables type conversion procedures #ifdef MFC_OpenACC use openacc @@ -33,9 +34,11 @@ module m_muscl real(wp), allocatable, dimension(:,:,:,:) :: v_rs_ws_x_muscl, v_rs_ws_y_muscl, v_rs_ws_z_muscl !> @} $:GPU_DECLARE(create='[v_rs_ws_x_muscl, v_rs_ws_y_muscl, v_rs_ws_z_muscl]') + contains subroutine s_initialize_muscl_module() + ! Initializing in x-direction is1_muscl%beg = -buff_size; is1_muscl%end = m - is1_muscl%beg if (n == 0) then @@ -55,7 +58,7 @@ contains is3_muscl%end = p - is3_muscl%beg @:ALLOCATE(v_rs_ws_x_muscl(is1_muscl%beg:is1_muscl%end, is2_muscl%beg:is2_muscl%end, is3_muscl%beg:is3_muscl%end, & - & 1:sys_size)) + & 1:sys_size)) if (n == 0) return @@ -72,7 +75,7 @@ contains is3_muscl%end = p - is3_muscl%beg @:ALLOCATE(v_rs_ws_y_muscl(is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, is3_muscl%beg:is3_muscl%end, & - & 1:sys_size)) + & 1:sys_size)) if (p == 0) return @@ -82,20 +85,23 @@ contains is3_muscl%beg = -buff_size; is3_muscl%end = p - is3_muscl%beg @:ALLOCATE(v_rs_ws_z_muscl(is3_muscl%beg:is3_muscl%end, is2_muscl%beg:is2_muscl%end, is1_muscl%beg:is1_muscl%end, & - & 1:sys_size)) + & 1:sys_size)) + end subroutine s_initialize_muscl_module !> @brief Performs MUSCL reconstruction of left and right cell-boundary values from cell-averaged variables. subroutine s_muscl(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, is1_muscl_d, & + & is2_muscl_d, is3_muscl_d) type(scalar_field), dimension(1:), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & - & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z integer, intent(in) :: muscl_dir type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d integer :: j, k, l, i real(wp) :: slopeL, slopeR, slope + is1_muscl = is1_muscl_d is2_muscl = is2_muscl_d is3_muscl = is3_muscl_d @@ -185,7 +191,7 @@ contains else if (muscl_lim == 5) then ! SUPERBEE if (slopeL*slopeR > 1e-6_wp) then slope = -1._wp*min(-min(2._wp*abs(slopeL), abs(slopeR)), -min(abs(slopeL), & - & 2._wp*abs(slopeR))) + & 2._wp*abs(slopeR))) end if end if @@ -205,22 +211,25 @@ contains if (int_comp) then call s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, & - & is1_muscl_d, is2_muscl_d, is3_muscl_d) + & is1_muscl_d, is2_muscl_d, is3_muscl_d) end if + end subroutine s_muscl !> @brief Applies THINC interface-compression to sharpen volume-fraction reconstructions at material interfaces. subroutine s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, & + & is1_muscl_d, is2_muscl_d, is3_muscl_d) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & - & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z integer, intent(in) :: muscl_dir type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d integer :: j, k, l real(wp) :: aCL, aCR, aC, aTHINC, qmin, qmax, A, B, C, sign, moncon #:for MUSCL_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + if (muscl_dir == ${MUSCL_DIR}$) then $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, aCL, aC, aCR, aTHINC, moncon, sign, qmin, qmax]') do l = is3_muscl%beg, is3_muscl%end @@ -252,9 +261,9 @@ contains if (aTHINC < ic_eps) aTHINC = ic_eps if (aTHINC > 1 - ic_eps) aTHINC = 1 - ic_eps vL_rs_vf_${XYZ}$ (j, k, l, contxb) = vL_rs_vf_${XYZ}$ (j, k, l, contxb)/vL_rs_vf_${XYZ}$ (j, k, & - & l, advxb)*aTHINC + & l, advxb)*aTHINC vL_rs_vf_${XYZ}$ (j, k, l, contxe) = vL_rs_vf_${XYZ}$ (j, k, l, & - & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) + & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) vL_rs_vf_${XYZ}$ (j, k, l, advxb) = aTHINC vL_rs_vf_${XYZ}$ (j, k, l, advxe) = 1 - aTHINC @@ -263,9 +272,9 @@ contains if (aTHINC < ic_eps) aTHINC = ic_eps if (aTHINC > 1 - ic_eps) aTHINC = 1 - ic_eps vR_rs_vf_${XYZ}$ (j, k, l, contxb) = vL_rs_vf_${XYZ}$ (j, k, l, contxb)/vL_rs_vf_${XYZ}$ (j, k, & - & l, advxb)*aTHINC + & l, advxb)*aTHINC vR_rs_vf_${XYZ}$ (j, k, l, contxe) = vL_rs_vf_${XYZ}$ (j, k, l, & - & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) + & contxe)/(1._wp - vL_rs_vf_${XYZ}$ (j, k, l, advxb))*(1._wp - aTHINC) vR_rs_vf_${XYZ}$ (j, k, l, advxb) = aTHINC vR_rs_vf_${XYZ}$ (j, k, l, advxe) = 1 - aTHINC end if @@ -275,18 +284,19 @@ contains $:END_GPU_PARALLEL_LOOP() end if #:endfor + end subroutine s_interface_compression !> @brief Reshapes cell-averaged variable data into direction-local work arrays for MUSCL reconstruction. subroutine s_initialize_muscl(v_vf, muscl_dir) + type(scalar_field), dimension(:), intent(in) :: v_vf integer, intent(in) :: muscl_dir integer :: j, k, l, q !< Generic loop iterators - ! Determining the number of cell-average variables which will be - ! muscl-reconstructed and mapping their indical bounds in the x-, - ! y- and z-directions to those in the s1-, s2- and s3-directions - ! as to reshape the inputted data in the coordinate direction of - ! the muscl reconstruction + ! Determining the number of cell-average variables which will be muscl-reconstructed and mapping their indical bounds in the + ! x-, y- and z-directions to those in the s1-, s2- and s3-directions as to reshape the inputted data in the coordinate + ! direction of the muscl reconstruction + v_size = ubound(v_vf, 1) $:GPU_UPDATE(device='[v_size]') @@ -336,10 +346,12 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_initialize_muscl !> @brief Deallocates the MUSCL direction-local work arrays. subroutine s_finalize_muscl_module() + @:DEALLOCATE(v_rs_ws_x_muscl) if (n == 0) return @@ -349,5 +361,7 @@ contains if (p == 0) return @:DEALLOCATE(v_rs_ws_z_muscl) + end subroutine s_finalize_muscl_module + end module m_muscl diff --git a/src/simulation/m_pressure_relaxation.fpp b/src/simulation/m_pressure_relaxation.fpp index 8c68973b60..3d77f35a6e 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -8,7 +8,8 @@ !> @brief Pressure relaxation for the six-equation multi-component model via Newton--Raphson equilibration and volume-fraction !! correction module m_pressure_relaxation - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters implicit none @@ -17,10 +18,12 @@ module m_pressure_relaxation real(wp), allocatable, dimension(:,:) :: Res_pr $:GPU_DECLARE(create='[Res_pr]') + contains !> Initialize the pressure relaxation module impure subroutine s_initialize_pressure_relaxation_module + integer :: i, j if (viscous) then @@ -32,18 +35,22 @@ contains end do $:GPU_UPDATE(device='[Res_pr, Re_idx, Re_size]') end if + end subroutine s_initialize_pressure_relaxation_module !> Finalize the pressure relaxation module impure subroutine s_finalize_pressure_relaxation_module + if (viscous) then @:DEALLOCATE(Res_pr) end if + end subroutine s_finalize_pressure_relaxation_module !> The main pressure relaxation procedure !! @param q_cons_vf Cell-average conservative variables subroutine s_pressure_relaxation_procedure(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf integer :: j, k, l @@ -56,10 +63,12 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_pressure_relaxation_procedure !> Process pressure relaxation for a single cell subroutine s_relax_cell_pressure(q_cons_vf, j, k, l) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -75,10 +84,12 @@ contains ! Internal energy correction call s_correct_internal_energies(q_cons_vf, j, k, l) + end subroutine s_relax_cell_pressure !> Check if pressure relaxation is needed for this cell logical function s_needs_pressure_relaxation(q_cons_vf, j, k, l) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -92,10 +103,12 @@ contains s_needs_pressure_relaxation = .false. end if end do + end function s_needs_pressure_relaxation !> Correct volume fractions to physical bounds subroutine s_correct_volume_fractions(q_cons_vf, j, k, l) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -119,10 +132,12 @@ contains do i = 1, num_fluids q_cons_vf(i + advxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, l)/sum_alpha end do + end subroutine s_correct_volume_fractions !> Main pressure equilibration using Newton-Raphson subroutine s_equilibrate_pressure(q_cons_vf, j, k, l) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -172,7 +187,7 @@ contains do i = 1, num_fluids if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then rho_K_s(i) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/max(q_cons_vf(i + advxb - 1)%sf(j, k, l), & - & sgm_eps)*((pres_relax + ps_inf(i))/(pres_K_init(i) + ps_inf(i)))**(1._wp/gs_min(i)) + & sgm_eps)*((pres_relax + ps_inf(i))/(pres_K_init(i) + ps_inf(i)))**(1._wp/gs_min(i)) f_pres = f_pres + q_cons_vf(i + contxb - 1)%sf(j, k, l)/rho_K_s(i) df_pres = df_pres - q_cons_vf(i + contxb - 1)%sf(j, k, l)/(gs_min(i)*rho_K_s(i)*(pres_relax + ps_inf(i))) end if @@ -186,10 +201,12 @@ contains if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) q_cons_vf(i + advxb - 1)%sf(j, k, & & l) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/rho_K_s(i) end do + end subroutine s_equilibrate_pressure !> Correct internal energies using equilibrated pressure subroutine s_correct_internal_energies(q_cons_vf, j, k, l) + $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -280,5 +297,7 @@ contains do i = 1, num_fluids q_cons_vf(i + intxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, l)*(gammas(i)*pres_relax + pi_infs(i)) end do + end subroutine s_correct_internal_energies + end module m_pressure_relaxation diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index 09bb409158..496b90d160 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -7,11 +7,12 @@ !> @brief Quadrature-based moment methods (QBMM) for polydisperse bubble moment inversion and transport module m_qbmm - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper implicit none @@ -34,13 +35,16 @@ module m_qbmm integer, allocatable, dimension(:) :: bubrs_qbmm integer, allocatable, dimension(:,:) :: bubmoms $:GPU_DECLARE(create='[bubrs_qbmm, bubmoms]') + contains !> @brief Allocates and initializes moment coefficient arrays for the QBMM module. impure subroutine s_initialize_qbmm_module + integer :: i1, i2, q, i, j #:if not MFC_CASE_OPTIMIZATION + if (bubble_model == 2) then ! Keller-Miksis without viscosity/surface tension nterms = 32 @@ -56,9 +60,8 @@ contains @:ALLOCATE(momrhs(1:3, 0:2, 0:2, 1:nterms, 1:nb)) momrhs = 0._wp - ! Assigns the required RHS moments for moment transport equations - ! The rhs%(:,3) is only to be used for R0 quadrature, not for computing X/Y indices - ! Accounts for different governing equations in polytropic and non-polytropic models + ! Assigns the required RHS moments for moment transport equations The rhs%(:,3) is only to be used for R0 quadrature, not + ! for computing X/Y indices Accounts for different governing equations in polytropic and non-polytropic models if (.not. polytropic) then do q = 1, nb do i1 = 0, 2; do i2 = 0, 2 @@ -395,17 +398,20 @@ contains end do end do $:GPU_UPDATE(device='[bubmoms]') + end subroutine s_initialize_qbmm_module !> @brief Computes the QBMM right-hand side source terms for bubble moment transport equations. subroutine s_compute_qbmm_rhs(idir, q_cons_vf, q_prim_vf, rhs_vf, flux_n_vf, pb, rhs_pb) + integer, intent(in) :: idir type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf, q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf type(scalar_field), dimension(sys_size), intent(in) :: flux_n_vf real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & - & intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. + & intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. integer :: i, j, k, l, q real(wp) :: nb_q, nb_dot, R, R2, nR, nR2, nR_dot, nR2_dot, var, AX @@ -442,108 +448,108 @@ contains select case (idir) case (1) nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j - 1, k, & - & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j - 1, k, & - & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j - 1, k, & - & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dx(j)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) case (2) nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k - 1, & - & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k - 1, & - & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k - 1, & - & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + & l) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dy(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) case (3) if (is_axisym) then nb_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, & - & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l)) + & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l)) nR_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, & - & k, l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)) + & k, l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)) nR2_dot = q_prim_vf(contxe + idir)%sf(j, k, l)*(flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, & - & k, l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)) + & k, l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, & - & i)) + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, & + & q, i)) else nb_dot = flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, & - & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) + & l - 1) - flux_n_vf(bubxb + (i - 1)*nmom)%sf(j, k, l) nR_dot = flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, & - & l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) + & l - 1) - flux_n_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l) nR2_dot = flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, & - & l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) + & l - 1) - flux_n_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2)*(nR_dot*nb_q - nR*nb_dot)*(pb(j, k, l, q, i)) end if end select if (q <= 2) then select case (idir) case (1) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & - & - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (2) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & - & - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (3) if (is_axisym) then rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & - & - nR2*nb_dot)*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & + & - nR2*nb_dot)*(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & - & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & - & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) + 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end select else select case (idir) case (1) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & - & - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dx(j)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (2) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & - & - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dy(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q)*(nR_dot*nb_q & + & - nR*nb_dot))*(pb(j, k, l, q, i)) case (3) if (is_axisym) then rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & - & - nR2*nb_dot)*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q & + & - nR2*nb_dot)*(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & - & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*y_cc(k)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) else rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & - & *(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(nR2_dot*nb_q - nR2*nb_dot) & + & *(pb(j, k, l, q, i)) rhs_pb(j, k, l, q, i) = rhs_pb(j, k, l, q, & - & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & - & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) + & i) - 3._wp*gam/(dz(l)*AX*nb_q**2*sqrt(var)*2._wp)*(-2._wp*(nR/nb_q) & + & *(nR_dot*nb_q - nR*nb_dot))*(pb(j, k, l, q, i)) end if end select end if @@ -578,10 +584,12 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_compute_qbmm_rhs !> @brief Builds the coefficient array for the non-polytropic bubble model. subroutine s_coeff_nonpoly(pres, rho, c, coeffs) + $:GPU_ROUTINE(function_name='s_coeff_nonpoly',parallelism='[seq]', cray_inline=True) real(wp), intent(in) :: pres, rho, c @@ -655,10 +663,12 @@ contains end if end if end do; end do + end subroutine s_coeff_nonpoly !> @brief Builds the coefficient array for the polytropic bubble model. subroutine s_coeff(pres, rho, c, coeffs) + $:GPU_ROUTINE(function_name='s_coeff',parallelism='[seq]', cray_inline=True) real(wp), intent(in) :: pres, rho, c @@ -722,10 +732,12 @@ contains end if end if end do; end do + end subroutine s_coeff !> @brief Performs moment inversion to recover quadrature weights and abscissas and evaluates bubble source terms. subroutine s_mom_inv(q_cons_vf, q_prim_vf, momsp, moms3d, pb, rhs_pb, mv, rhs_mv, ix, iy, iz) + type(scalar_field), dimension(:), intent(inout) :: q_cons_vf, q_prim_vf type(scalar_field), dimension(:), intent(inout) :: momsp type(scalar_field), dimension(0:, 0:,:), intent(inout) :: moms3d @@ -754,7 +766,8 @@ contains $:GPU_UPDATE(device='[is1_qbmm, is2_qbmm, is3_qbmm]') $:GPU_PARALLEL_LOOP(collapse=3, private='[id1, id2, id3, moms, msum, wght, abscX, abscY, wght_pb, wght_mv, wght_ht, coeff, & - & ht, r, q, n_tait, B_tait, pres, rho, nbub, c, alf, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, grad_T, i1, i2, j]') + & ht, r, q, n_tait, B_tait, pres, rho, nbub, c, alf, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, & + & grad_T, i1, i2, j]') do id3 = is3_qbmm%beg, is3_qbmm%end do id2 = is2_qbmm%beg, is2_qbmm%end do id1 = is1_qbmm%beg, is1_qbmm%end @@ -794,14 +807,15 @@ contains chi_vw = 1._wp/(1._wp + R_v/R_g*(pb(id1, id2, id3, j, q)/pv - 1._wp)) x_vw = M_g*chi_vw/(M_v + (M_g - M_v)*chi_vw) k_mw = x_vw*k_v(q)/(x_vw + (1._wp - x_vw)*phi_vg) + (1._wp - x_vw)*k_g(q)/(x_vw*phi_gv & - & + 1._wp - x_vw) + & + 1._wp - x_vw) rho_mw = pv/(chi_vw*R_v*Tw) rhs_mv(id1, id2, id3, j, q) = -Re_trans_c(q)*((mv(id1, id2, id3, j, q)/(mv(id1, id2, id3, j, & - & q) + mass_g0(q))) - chi_vw) + & q) + mass_g0(q))) - chi_vw) rhs_mv(id1, id2, id3, j, q) = rho_mw*rhs_mv(id1, id2, id3, j, & - & q)/Pe_c/(1._wp - chi_vw)/abscX(j, q) + & q)/Pe_c/(1._wp - chi_vw)/abscX(j, q) grad_T = -Re_trans_T(q)*((pb(id1, id2, id3, j, q)/pb0(q))*(abscX(j, & - & q)/R0(q))**3*(mass_g0(q) + mass_v0(q))/(mass_g0(q) + mv(id1, id2, id3, j, q)) - 1._wp) + & q)/R0(q))**3*(mass_g0(q) + mass_v0(q))/(mass_g0(q) + mv(id1, id2, id3, & + & j, q)) - 1._wp) ht(j, q) = pb0(q)*k_mw*grad_T/Pe_T(q)/abscX(j, q) wght_pb(j, q) = wght(j, q)*(pb(id1, id2, id3, j, q)) wght_mv(j, q) = wght(j, q)*(rhs_mv(id1, id2, id3, j, q)) @@ -823,31 +837,31 @@ contains case (3) if (j == 3) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, & - & j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, & + & q), momrhs(:, i1, i2, j, q)) else momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), momrhs(:, i1, i2, j, & - & q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), & + & momrhs(:, i1, i2, j, q)) end if case (2) if ((j >= 7 .and. j <= 9) .or. (j >= 22 .and. j <= 23) & & .or. (j >= 10 .and. j <= 11) .or. (j == 26)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, q), momrhs(:, i1, i2, & - & j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, & + & q), momrhs(:, i1, i2, j, q)) else if ((j >= 27 .and. j <= 29) .and. (.not. polytropic)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, q), momrhs(:, i1, i2, & - & j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, & + & q), momrhs(:, i1, i2, j, q)) else if ((j >= 30 .and. j <= 32) .and. (.not. polytropic)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, q), momrhs(:, i1, i2, & - & j, q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, & + & q), momrhs(:, i1, i2, j, q)) else momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), momrhs(:, i1, i2, j, & - & q)) + & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), & + & momrhs(:, i1, i2, j, q)) end if end select end do @@ -864,12 +878,12 @@ contains do j = 1, nnode drdt = msum(2) drdt2 = merge(-1._wp, 1._wp, j == 1 .or. j == 2)/(2._wp*sqrt(merge(moms(4) - moms(2)**2._wp, & - & sgm_eps, moms(4) - moms(2)**2._wp > 0._wp))) + & sgm_eps, moms(4) - moms(2)**2._wp > 0._wp))) drdt2 = drdt2*(msum(3) - 2._wp*moms(2)*msum(2)) drdt = drdt + drdt2 rhs_pb(id1, id2, id3, j, q) = (-3._wp*gam*drdt/abscX(j, q))*(pb(id1, id2, id3, j, q)) rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3._wp*gam/abscX(j, & - & q))*rhs_mv(id1, id2, id3, j, q)*R_v*Tw + & q))*rhs_mv(id1, id2, id3, j, q)*R_v*Tw rhs_pb(id1, id2, id3, j, q) = rhs_pb(id1, id2, id3, j, q) + (3._wp*gam/abscX(j, q))*ht(j, q) rhs_mv(id1, id2, id3, j, q) = rhs_mv(id1, id2, id3, j, q)*(4._wp*pi*abscX(j, q)**2._wp) end do @@ -885,13 +899,13 @@ contains else if (polytropic) then momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3._wp*(1._wp - gam), 0._wp, & - & 3._wp*gam) + pv*f_quad(abscX, abscY, wght, 3._wp, 0._wp, & - & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & - & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) + & 3._wp*gam) + pv*f_quad(abscX, abscY, wght, 3._wp, 0._wp, & + & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & + & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) else momsp(4)%sf(id1, id2, id3) = f_quad(abscX, abscY, wght_pb, 3._wp, 0._wp, & - & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & - & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) + & 0._wp) - 4._wp*Re_inv*f_quad(abscX, abscY, wght, 2._wp, 1._wp, & + & 0._wp) - (2._wp/Web)*f_quad(abscX, abscY, wght, 2._wp, 0._wp, 0._wp) end if end if else @@ -914,9 +928,11 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() + contains !> @brief Selects the polytropic or non-polytropic coefficient routine. subroutine s_coeff_selector(pres, rho, c, coeff, polytropic) + $:GPU_ROUTINE(function_name='s_coeff_selector',parallelism='[seq]', cray_inline=True) real(wp), intent(in) :: pres, rho, c #:if USING_AMD @@ -930,10 +946,12 @@ contains else call s_coeff_nonpoly(pres, rho, c, coeff) end if + end subroutine s_coeff_selector !> @brief Performs conditional hyperbolic QMOM (CHyQMOM) inversion for bivariate moments. subroutine s_chyqmom(momin, wght, abscX, abscY) + $:GPU_ROUTINE(function_name='s_chyqmom',parallelism='[seq]', cray_inline=True) real(wp), dimension(nmom), intent(in) :: momin @@ -987,10 +1005,12 @@ contains ! Compute abscissas (vectorized) abscX = bu + [up(1), up(1), up(2), up(2)] abscY = bv + [Vf(1) + vp21, Vf(1) + vp22, Vf(2) + vp21, Vf(2) + vp22] + end subroutine s_chyqmom !> @brief Performs hyperbolic QMOM (HyQMOM) inversion for univariate moments. subroutine s_hyqmom(frho, fup, fmom) + $:GPU_ROUTINE(function_name='s_hyqmom',parallelism='[seq]', cray_inline=True) real(wp), dimension(2), intent(inout) :: frho, fup @@ -1005,10 +1025,12 @@ contains c2 = maxval((/c2, sgm_eps/)) fup(1) = bu - sqrt(c2) fup(2) = bu + sqrt(c2) + end subroutine s_hyqmom !> @brief Evaluates a weighted quadrature sum over all bubble size bins and nodes. function f_quad(abscX, abscY, wght_in, q, r, s) + $:GPU_ROUTINE(parallelism='[seq]') #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(4, 3), intent(in) :: abscX, abscY, wght_in @@ -1029,10 +1051,12 @@ contains end do f_quad = f_quad + weight(i)*(R0(i)**s)*f_quad_RV end do + end function f_quad !> @brief Evaluates a weighted 2D quadrature sum over quadrature nodes for a single size bin. function f_quad2D(abscX, abscY, wght_in, pow) + $:GPU_ROUTINE(parallelism='[seq]') #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(4), intent(in) :: abscX, abscY, wght_in @@ -1048,6 +1072,9 @@ contains do i = 1, nnode f_quad2D = f_quad2D + wght_in(i)*(abscX(i)**pow(1))*(abscY(i)**pow(2)) end do + end function f_quad2D + end subroutine s_mom_inv + end module m_qbmm diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index dd57feff6b..ba7af08ddf 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -8,17 +8,18 @@ !> @brief Assembles the right-hand side of the governing equations using finite-volume flux differencing, Riemann solvers, and !! physical source terms module m_rhs - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_weno !< Weighted and essentially non-oscillatory (WENO) schemes for spatial reconstruction of variables - use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws - use m_riemann_solvers !< Exact and approximate Riemann problem solvers - use m_cbc !< Characteristic boundary conditions (CBC) - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines + use m_weno !< Weighted and essentially non-oscillatory (WENO) schemes for spatial reconstruction of variables + use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws + use m_riemann_solvers !< Exact and approximate Riemann problem solvers + use m_cbc !< Characteristic boundary conditions (CBC) + use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines use m_bubbles_EL - use m_qbmm !< Moment inversion + use m_qbmm !< Moment inversion use m_hypoelastic use m_hyperelastic use m_acoustic_src @@ -37,15 +38,13 @@ module m_rhs private; public :: s_initialize_rhs_module, s_compute_rhs, s_finalize_rhs_module - !! This variable contains the WENO-reconstructed values of the cell-average - !! conservative variables, which are located in q_cons_vf, at cell-interior - !! Gaussian quadrature points (QP). + !! This variable contains the WENO-reconstructed values of the cell-average conservative variables, which are located in + !! q_cons_vf, at cell-interior Gaussian quadrature points (QP). type(vector_field) :: q_cons_qp $:GPU_DECLARE(create='[q_cons_qp]') - !! The primitive variables at cell-interior Gaussian quadrature points. These - !! are calculated from the conservative variables and gradient magnitude (GM) - !! of the volume fractions, q_cons_qp and gm_alpha_qp, respectively. + !! The primitive variables at cell-interior Gaussian quadrature points. These are calculated from the conservative variables and + !! gradient magnitude (GM) of the volume fractions, q_cons_qp and gm_alpha_qp, respectively. type(vector_field) :: q_prim_qp $:GPU_DECLARE(create='[q_prim_qp]') @@ -97,7 +96,6 @@ module m_rhs #if defined(MFC_OpenACC) $:GPU_DECLARE(create='[flux_n, flux_src_n, flux_gsrc_n]') #endif - !> @} type(vector_field), allocatable, dimension(:) :: qL_prim, qR_prim @@ -132,12 +130,15 @@ module m_rhs real(wp), allocatable, dimension(:,:,:) :: nbub !< Bubble number density $:GPU_DECLARE(create='[nbub]') + contains !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_rhs_module + integer :: i, j, k, l, id !< Generic loop iterators + $:GPU_ENTER_DATA(copyin='[idwbuff]') $:GPU_UPDATE(device='[idwbuff]') @@ -147,26 +148,25 @@ contains if (.not. igr) then do l = 1, sys_size @:ALLOCATE(q_cons_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do do l = mom_idx%beg, E_idx @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if if (surface_tension) then - ! This assumes that the color function advection equation is - ! the last equation. If this changes then this logic will + ! This assumes that the color function advection equation is the last equation. If this changes then this logic will ! need updated do l = adv_idx%end + 1, sys_size - 1 @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do else do l = adv_idx%end + 1, sys_size @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -177,7 +177,7 @@ contains if (relativity) then ! Cons and Prim densities are different for relativity @:ALLOCATE(q_prim_qp%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) else q_prim_qp%vf(l)%sf => q_cons_qp%vf(l)%sf $:GPU_ENTER_DATA(copyin='[q_prim_qp%vf(l)%sf]') @@ -218,42 +218,42 @@ contains if (i == 1) then do l = 1, sys_size @:ALLOCATE(flux_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do if (viscous .or. surface_tension) then do l = mom_idx%beg, E_idx @:ALLOCATE(flux_src_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if @:ALLOCATE(flux_src_n(i)%vf(adv_idx%beg)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) if (riemann_solver == 1 .or. riemann_solver == 4) then do l = adv_idx%beg + 1, adv_idx%end @:ALLOCATE(flux_src_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if if (chemistry) then do l = chemxb, chemxe @:ALLOCATE(flux_src_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do if (chem_params%diffusion .and. .not. viscous) then @:ALLOCATE(flux_src_n(i)%vf(E_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end if end if else do l = 1, sys_size @:ALLOCATE(flux_gsrc_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -301,40 +301,40 @@ contains @:ALLOCATE(qR_prim(i)%vf(1:sys_size)) do l = mom_idx%beg, mom_idx%end @:ALLOCATE(qL_prim(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ALLOCATE(qR_prim(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(qL_prim(i), qR_prim(i)) end do @:ALLOCATE(qL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:sys_size)) + & 1:sys_size)) @:ALLOCATE(qR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:sys_size)) + & 1:sys_size)) if (n > 0) then @:ALLOCATE(qL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:sys_size)) + & 1:sys_size)) @:ALLOCATE(qR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:sys_size)) + & 1:sys_size)) else @:ALLOCATE(qL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:sys_size)) + & 1:sys_size)) @:ALLOCATE(qR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:sys_size)) + & 1:sys_size)) end if if (p > 0) then @:ALLOCATE(qL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & - & 1:sys_size)) + & 1:sys_size)) @:ALLOCATE(qR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & - & 1:sys_size)) + & 1:sys_size)) else @:ALLOCATE(qL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:sys_size)) + & 1:sys_size)) @:ALLOCATE(qR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:sys_size)) + & 1:sys_size)) end if if (.not. viscous) then @@ -363,11 +363,11 @@ contains @:ALLOCATE(tau_Re_vf(1:sys_size)) do i = 1, num_dims @:ALLOCATE(tau_Re_vf(cont_idx%end + i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(tau_Re_vf(cont_idx%end + i)) end do @:ALLOCATE(tau_Re_vf(E_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(tau_Re_vf(E_idx)) @:ALLOCATE(dq_prim_dx_qp(1)%vf(1:sys_size)) @@ -376,7 +376,7 @@ contains do l = mom_idx%beg, mom_idx%end @:ALLOCATE(dq_prim_dx_qp(1)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dx_qp(1)) @@ -384,7 +384,7 @@ contains if (n > 0) then do l = mom_idx%beg, mom_idx%end @:ALLOCATE(dq_prim_dy_qp(1)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dy_qp(1)) @@ -392,7 +392,7 @@ contains if (p > 0) then do l = mom_idx%beg, mom_idx%end @:ALLOCATE(dq_prim_dz_qp(1)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(dq_prim_dz_qp(1)) end if @@ -410,26 +410,26 @@ contains do i = 1, num_dims do l = mom_idx%beg, mom_idx%end @:ALLOCATE(dqL_prim_dx_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ALLOCATE(dqR_prim_dx_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do if (n > 0) then do l = mom_idx%beg, mom_idx%end @:ALLOCATE(dqL_prim_dy_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ALLOCATE(dqR_prim_dy_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if if (p > 0) then do l = mom_idx%beg, mom_idx%end @:ALLOCATE(dqL_prim_dz_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ALLOCATE(dqR_prim_dz_n(i)%vf(l)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do end if @@ -439,32 +439,32 @@ contains if (weno_Re_flux) then @:ALLOCATE(dqL_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsx_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) if (n > 0) then @:ALLOCATE(dqL_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsy_vf(idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) else @:ALLOCATE(dqL_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsy_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) end if if (p > 0) then @:ALLOCATE(dqL_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsz_vf(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(1)%beg:idwbuff(1)%end, mom_idx%beg:mom_idx%end)) else @:ALLOCATE(dqL_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) @:ALLOCATE(dqR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) + & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) end if end if ! end allocation for weno_Re_flux else @@ -508,7 +508,7 @@ contains do j = 0, 2 do k = 1, nb @:ALLOCATE(mom_3d(i, j, k)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(mom_3d(i, j, k)) end do end do @@ -516,7 +516,7 @@ contains do i = 1, nmomsp @:ALLOCATE(mom_sp(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(mom_sp(i)) end do end if @@ -534,7 +534,7 @@ contains if (alt_soundspeed) then @:ALLOCATE(blkmod1(0:m, 0:n, 0:p), blkmod2(0:m, 0:n, 0:p), alpha1(0:m, 0:n, 0:p), alpha2(0:m, 0:n, 0:p), Kterm(0:m, & - & 0:n, 0:p)) + & 0:n, 0:p)) end if call s_initialize_pressure_relaxation_module @@ -542,10 +542,12 @@ contains if (bubbles_euler) then @:ALLOCATE(nbub(0:m, 0:n, 0:p)) end if + end subroutine s_initialize_rhs_module !> @brief Computes the right-hand side of the semi-discrete governing equations for a single time stage. impure subroutine s_compute_rhs(q_cons_vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_in, rhs_pb, mv_in, rhs_mv, t_step, & + & time_avg, stage) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -554,17 +556,18 @@ contains type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & - & intent(inout) & - & :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now + & intent(inout) & + & :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: mv_in - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv - integer, intent(in) :: t_step - real(wp), intent(inout) :: time_avg - integer, intent(in) :: stage - real(wp) :: t_start, t_finish - integer :: id - integer(kind=8) :: i, j, k, l, q !< Generic loop iterators + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv + integer, intent(in) :: t_step + real(wp), intent(inout) :: time_avg + integer, intent(in) :: stage + real(wp) :: t_start, t_finish + integer :: id + integer(kind=8) :: i, j, k, l, q !< Generic loop iterators call nvtxStartRange("COMPUTE-RHS") call cpu_time(t_start) @@ -598,7 +601,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - 1 q_cons_qp%vf(i)%sf(j, k, l) = q_cons_qp%vf(i)%sf(j, k, l)*(1._wp - q_cons_qp%vf(alf_idx)%sf(j, k, & - & l))/alf_sum%sf(j, k, l) + & l))/alf_sum%sf(j, k, l) end do end do end do @@ -638,8 +641,8 @@ contains if ((viscous .and. .not. igr) .or. dummy) then call nvtxStartRange("RHS-VISCOUS") call s_get_viscous(qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, qL_prim, qR_rsx_vf, & - & qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, q_prim_qp, dq_prim_dx_qp, & - & dq_prim_dy_qp, dq_prim_dz_qp, idwbuff(1), idwbuff(2), idwbuff(3)) + & qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, q_prim_qp, & + & dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, idwbuff(1), idwbuff(2), idwbuff(3)) call nvtxEndRange end if @@ -690,41 +693,41 @@ contains ! Reconstruct densitiess iv%beg = 1; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(1:sys_size), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) else iv%beg = 1; iv%end = contxe call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) end if else if (all(Re_size == 0)) then iv%beg = 1; iv%end = E_idx - 1 call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = E_idx call s_reconstruct_cell_boundary_values_first_order(q_prim_qp%vf(E_idx), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx + 1; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) else iv%beg = 1; iv%end = contxe call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx; iv%end = E_idx call s_reconstruct_cell_boundary_values_first_order(q_prim_qp%vf(E_idx), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx + 1; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) end if end if @@ -732,18 +735,23 @@ contains if (weno_Re_flux) then iv%beg = momxb; iv%end = momxe call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dx_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), & - & dqR_prim_dx_n(id)%vf(iv%beg:iv%end), idwbuff(1), idwbuff(2), idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & + & dqR_rsz_vf, id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), & + & dqR_prim_dx_n(id)%vf(iv%beg:iv%end), idwbuff(1), & + & idwbuff(2), idwbuff(3)) if (n > 0) then call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dy_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, & - & dqL_prim_dy_n(id)%vf(iv%beg:iv%end), dqR_prim_dy_n(id)%vf(iv%beg:iv%end), idwbuff(1), idwbuff(2), & - & idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & + & dqR_rsz_vf, id, dqL_prim_dy_n(id)%vf(iv%beg:iv%end), & + & dqR_prim_dy_n(id)%vf(iv%beg:iv%end), idwbuff(1), & + & idwbuff(2), idwbuff(3)) if (p > 0) then call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dz_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, & - & dqL_prim_dz_n(id)%vf(iv%beg:iv%end), dqR_prim_dz_n(id)%vf(iv%beg:iv%end), idwbuff(1), & - & idwbuff(2), idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & + & dqR_rsz_vf, id, & + & dqL_prim_dz_n(id)%vf(iv%beg:iv%end), & + & dqR_prim_dz_n(id)%vf(iv%beg:iv%end), idwbuff(1), & + & idwbuff(2), idwbuff(3)) end if end if end if @@ -759,23 +767,21 @@ contains irx%beg = 0; iry%beg = 0; irz%beg = -1 end if irx%end = m; iry%end = n; irz%end = p - ! $:GPU_UPDATE(host='[qL_rsx_vf,qR_rsx_vf]') - ! print *, "L", qL_rsx_vf(100:300, 0, 0, 1) - ! print *, "R", qR_rsx_vf(100:300, 0, 0, 1) + ! $:GPU_UPDATE(host='[qL_rsx_vf,qR_rsx_vf]') print *, "L", qL_rsx_vf(100:300, 0, 0, 1) print *, "R", + ! qR_rsx_vf(100:300, 0, 0, 1) ! Computing Riemann Solver Flux and Source Flux call nvtxStartRange("RHS-RIEMANN-SOLVER") call s_riemann_solver(qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n(id)%vf, dqR_prim_dy_n(id)%vf, & - & dqR_prim_dz_n(id)%vf, qR_prim(id)%vf, qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, dqL_prim_dx_n(id)%vf, & - & dqL_prim_dy_n(id)%vf, dqL_prim_dz_n(id)%vf, qL_prim(id)%vf, q_prim_qp%vf, flux_n(id)%vf, flux_src_n(id)%vf, & - & flux_gsrc_n(id)%vf, id, irx, iry, irz) + & dqR_prim_dz_n(id)%vf, qR_prim(id)%vf, qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & + & dqL_prim_dx_n(id)%vf, dqL_prim_dy_n(id)%vf, dqL_prim_dz_n(id)%vf, qL_prim(id)%vf, & + & q_prim_qp%vf, flux_n(id)%vf, flux_src_n(id)%vf, flux_gsrc_n(id)%vf, id, irx, iry, irz) call nvtxEndRange !$:GPU_UPDATE(host='[flux_n(1)%vf(1)%sf]') ! print *, "FLUX", flux_n(1)%vf(1)%sf(100:300, 0, 0) - ! Additional physics and source terms - ! RHS addition for advection source + ! Additional physics and source terms RHS addition for advection source call nvtxStartRange("RHS-ADVECTION-SRC") call s_compute_advection_source_term(id, rhs_vf, q_cons_qp, q_prim_qp, flux_src_n(id)) call nvtxEndRange @@ -796,7 +802,7 @@ contains if (viscous .or. surface_tension .or. chem_params%diffusion) then call nvtxStartRange("RHS-ADD-PHYSICS") call s_compute_additional_physics_rhs(id, q_prim_qp%vf, rhs_vf, flux_src_n(id)%vf, dq_prim_dx_qp(1)%vf, & - & dq_prim_dy_qp(1)%vf, dq_prim_dz_qp(1)%vf) + & dq_prim_dy_qp(1)%vf, dq_prim_dz_qp(1)%vf) call nvtxEndRange end if @@ -821,7 +827,7 @@ contains do k = 0, n do j = 0, m rhs_vf(psi_idx)%sf(j, k, l) = rhs_vf(psi_idx)%sf(j, k, l) - q_prim_vf(psi_idx)%sf(j, k, & - & l)/hyper_cleaning_tau + & l)/hyper_cleaning_tau end do end do end do @@ -849,8 +855,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if - ! Additional Physics and Source Terms - ! Additions for acoustic_source + ! Additional Physics and Source Terms Additions for acoustic_source if (acoustic_source) then call nvtxStartRange("RHS-ACOUSTIC-SRC") call s_acoustic_src_calculations(q_cons_qp%vf(1:sys_size), q_prim_qp%vf(1:sys_size), rhs_vf) @@ -912,20 +917,22 @@ contains end if call nvtxEndRange + end subroutine s_compute_rhs !> @brief Accumulates advection source contributions from a given coordinate direction into the RHS. subroutine s_compute_advection_source_term(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf) - integer, intent(in) :: idir + + integer, intent(in) :: idir type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - type(vector_field), intent(inout) :: q_cons_vf - type(vector_field), intent(inout) :: q_prim_vf - type(vector_field), intent(inout) :: flux_src_n_vf - integer :: j, k, l, q ! Loop iterators from original, meaning varies - integer :: k_loop, l_loop, q_loop ! Standardized spatial loop iterators 0:m, 0:n, 0:p - integer :: i_fluid_loop - real(wp) :: inv_ds, flux_face1, flux_face2 - real(wp) :: advected_qty_val, pressure_val, velocity_val + type(vector_field), intent(inout) :: q_cons_vf + type(vector_field), intent(inout) :: q_prim_vf + type(vector_field), intent(inout) :: flux_src_n_vf + integer :: j, k, l, q ! Loop iterators from original, meaning varies + integer :: k_loop, l_loop, q_loop ! Standardized spatial loop iterators 0:m, 0:n, 0:p + integer :: i_fluid_loop + real(wp) :: inv_ds, flux_face1, flux_face2 + real(wp) :: advected_qty_val, pressure_val, velocity_val if (alt_soundspeed) then $:GPU_PARALLEL_LOOP(private='[k_loop, l_loop, q_loop]', collapse=3) @@ -933,9 +940,9 @@ contains do l_loop = 0, n do k_loop = 0, m blkmod1(k_loop, l_loop, q_loop) = ((gammas(1) + 1._wp)*q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, & - & q_loop) + pi_infs(1))/gammas(1) + & q_loop) + pi_infs(1))/gammas(1) blkmod2(k_loop, l_loop, q_loop) = ((gammas(2) + 1._wp)*q_prim_vf%vf(E_idx)%sf(k_loop, l_loop, & - & q_loop) + pi_infs(2))/gammas(2) + & q_loop) + pi_infs(2))/gammas(2) alpha1(k_loop, l_loop, q_loop) = q_cons_vf%vf(advxb)%sf(k_loop, l_loop, q_loop) if (bubbles_euler) then @@ -945,9 +952,9 @@ contains end if Kterm(k_loop, l_loop, q_loop) = alpha1(k_loop, l_loop, q_loop)*alpha2(k_loop, l_loop, & - & q_loop)*(blkmod2(k_loop, l_loop, q_loop) - blkmod1(k_loop, l_loop, q_loop))/(alpha1(k_loop, l_loop, & - & q_loop)*blkmod2(k_loop, l_loop, q_loop) + alpha2(k_loop, l_loop, q_loop)*blkmod1(k_loop, l_loop, & - & q_loop)) + & q_loop)*(blkmod2(k_loop, l_loop, q_loop) - blkmod1(k_loop, l_loop, q_loop))/(alpha1(k_loop, & + & l_loop, q_loop)*blkmod2(k_loop, l_loop, q_loop) + alpha2(k_loop, l_loop, q_loop)*blkmod1(k_loop, & + & l_loop, q_loop)) end do end do end do @@ -980,7 +987,7 @@ contains if (model_eqns == 3) then $:GPU_PARALLEL_LOOP(collapse=4,private='[i_fluid_loop, k_loop, l_loop, q_loop, inv_ds, advected_qty_val, & - & pressure_val, flux_face1, flux_face2]') + & pressure_val, flux_face1, flux_face2]') do q_loop = 0, p do l_loop = 0, n do k_loop = 0, m @@ -991,8 +998,8 @@ contains flux_face1 = flux_src_n_vf%vf(advxb)%sf(k_loop, l_loop, q_loop) flux_face2 = flux_src_n_vf%vf(advxb)%sf(k_loop - 1, l_loop, q_loop) rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, & - & q_loop) = rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, & - & q_loop) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + & q_loop) = rhs_vf(i_fluid_loop + intxb - 1)%sf(k_loop, l_loop, & + & q_loop) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) end do end do end do @@ -1026,7 +1033,7 @@ contains if (model_eqns == 3) then $:GPU_PARALLEL_LOOP(collapse=4, private='[i_fluid_loop, k, l, q, inv_ds, advected_qty_val, pressure_val, & - & flux_face1, flux_face2]') + & flux_face1, flux_face2]') do l = 0, p do k = 0, n do q = 0, m @@ -1037,10 +1044,10 @@ contains flux_face1 = flux_src_n_vf%vf(advxb)%sf(q, k, l) flux_face2 = flux_src_n_vf%vf(advxb)%sf(q, k - 1, l) rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) = rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, & - & l) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + & l) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) if (cyl_coord) then rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, l) = rhs_vf(i_fluid_loop + intxb - 1)%sf(q, k, & - & l) - 5.e-1_wp/y_cc(k)*advected_qty_val*pressure_val*(flux_face1 + flux_face2) + & l) - 5.e-1_wp/y_cc(k)*advected_qty_val*pressure_val*(flux_face1 + flux_face2) end if end do end do @@ -1122,7 +1129,7 @@ contains if (model_eqns == 3) then $:GPU_PARALLEL_LOOP(collapse=4, private='[i_fluid_loop, k, l, q, inv_ds, advected_qty_val, pressure_val, & - & flux_face1, flux_face2]') + & flux_face1, flux_face2]') do k = 0, p do q = 0, n do l = 0, m @@ -1133,7 +1140,7 @@ contains flux_face1 = flux_src_n_vf%vf(advxb)%sf(l, q, k) flux_face2 = flux_src_n_vf%vf(advxb)%sf(l, q, k - 1) rhs_vf(i_fluid_loop + intxb - 1)%sf(l, q, k) = rhs_vf(i_fluid_loop + intxb - 1)%sf(l, q, & - & k) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) + & k) - inv_ds*advected_qty_val*pressure_val*(flux_face1 - flux_face2) end do end do end do @@ -1143,10 +1150,12 @@ contains call s_add_directional_advection_source_terms(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf, Kterm) end select + contains !> @brief Adds the advection source flux-difference terms for a single coordinate direction to the RHS. subroutine s_add_directional_advection_source_terms(current_idir, rhs_vf_arg, q_cons_vf_arg, q_prim_vf_arg, & + & flux_src_n_vf_arg, Kterm_arg) integer, intent(in) :: current_idir type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf_arg @@ -1165,7 +1174,7 @@ contains use_standard_riemann = (riemann_solver == 1 .or. riemann_solver == 4) if (use_standard_riemann) then $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & - & local_flux1, local_flux2]') + & local_flux1, local_flux2]') do j_adv = advxb, advxe do q_idx = 0, p ! z_extent do l_idx = 0, n ! y_extent @@ -1175,7 +1184,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx - 1, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(j_adv)%sf(k_idx, l_idx, & - & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1185,7 +1194,7 @@ contains if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & - & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do q_idx = 0, p; do l_idx = 0, n; do k_idx = 0, m local_inv_ds = 1._wp/dx(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) @@ -1194,12 +1203,12 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx - 1, l_idx, q_idx) rhs_vf_arg(advxe)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(advxe)%sf(k_idx, l_idx, & - & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do $:END_GPU_PARALLEL_LOOP() $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & - & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do q_idx = 0, p; do l_idx = 0, n; do k_idx = 0, m local_inv_ds = 1._wp/dx(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) @@ -1208,13 +1217,13 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx - 1, l_idx, q_idx) rhs_vf_arg(advxb)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(advxb)%sf(k_idx, l_idx, & - & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if else ! NOT alt_soundspeed $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & - & local_flux1, local_flux2]') + & local_flux1, local_flux2]') do j_adv = advxb, advxe do q_idx = 0, p; do l_idx = 0, n; do k_idx = 0, m local_inv_ds = 1._wp/dx(k_idx) @@ -1222,18 +1231,18 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx - 1, l_idx, q_idx) rhs_vf_arg(j_adv)%sf(k_idx, l_idx, q_idx) = rhs_vf_arg(j_adv)%sf(k_idx, l_idx, & - & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & q_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() end if end if case (2) & - & ! y-direction: loops q_idx (x), k_idx (y), l_idx (z); sf(q_idx, k_idx, l_idx); dy(k_idx); Kterm(q_idx,k_idx,l_idx) + & ! y-direction: loops q_idx (x), k_idx (y), l_idx (z); sf(q_idx, k_idx, l_idx); dy(k_idx); Kterm(q_idx,k_idx,l_idx) use_standard_riemann = (riemann_solver == 1 .or. riemann_solver == 4) if (use_standard_riemann) then $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & - & local_flux1, local_flux2]') + & local_flux1, local_flux2]') do j_adv = advxb, advxe do l_idx = 0, p ! z_extent do k_idx = 0, n ! y_extent @@ -1243,7 +1252,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx - 1, l_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(j_adv)%sf(q_idx, k_idx, & - & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1253,7 +1262,7 @@ contains if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & - & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do l_idx = 0, p; do k_idx = 0, n; do q_idx = 0, m local_inv_ds = 1._wp/dy(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) @@ -1262,16 +1271,16 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx - 1, l_idx) rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxe)%sf(q_idx, k_idx, & - & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) if (cyl_coord) then rhs_vf_arg(advxe)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxe)%sf(q_idx, k_idx, & - & l_idx) - (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) + & l_idx) - (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) end if end do; end do; end do $:END_GPU_PARALLEL_LOOP() $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & - & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do l_idx = 0, p; do k_idx = 0, n; do q_idx = 0, m local_inv_ds = 1._wp/dy(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) @@ -1280,17 +1289,17 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx - 1, l_idx) rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxb)%sf(q_idx, k_idx, & - & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) if (cyl_coord) then rhs_vf_arg(advxb)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(advxb)%sf(q_idx, k_idx, & - & l_idx) + (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) + & l_idx) + (local_k_term_val/(2._wp*y_cc(k_idx)))*(local_flux1 + local_flux2) end if end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if else ! NOT alt_soundspeed $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & - & local_flux1, local_flux2]') + & local_flux1, local_flux2]') do j_adv = advxb, advxe do l_idx = 0, p; do k_idx = 0, n; do q_idx = 0, m local_inv_ds = 1._wp/dy(k_idx) @@ -1298,14 +1307,14 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx, l_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx - 1, l_idx) rhs_vf_arg(j_adv)%sf(q_idx, k_idx, l_idx) = rhs_vf_arg(j_adv)%sf(q_idx, k_idx, & - & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & l_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() end if end if case (3) & - & ! z-direction: loops l_idx (x), q_idx (y), k_idx (z); sf(l_idx, q_idx, k_idx); dz(k_idx); Kterm(l_idx,q_idx,k_idx) + & ! z-direction: loops l_idx (x), q_idx (y), k_idx (z); sf(l_idx, q_idx, k_idx); dz(k_idx); Kterm(l_idx,q_idx,k_idx) if (grid_geometry == 3) then use_standard_riemann = (riemann_solver == 1) else @@ -1314,7 +1323,7 @@ contains if (use_standard_riemann) then $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & - & local_flux1, local_flux2]') + & local_flux1, local_flux2]') do j_adv = advxb, advxe do k_idx = 0, p ! z_extent do q_idx = 0, n ! y_extent @@ -1324,7 +1333,7 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx - 1) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(j_adv)%sf(l_idx, q_idx, & - & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do end do end do @@ -1334,7 +1343,7 @@ contains if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & - & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do k_idx = 0, p; do q_idx = 0, n; do l_idx = 0, m local_inv_ds = 1._wp/dz(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) @@ -1343,12 +1352,12 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx - 1) rhs_vf_arg(advxe)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(advxe)%sf(l_idx, q_idx, & - & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do $:END_GPU_PARALLEL_LOOP() $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & - & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') + & local_k_term_val, local_term_coeff, local_flux1, local_flux2]') do k_idx = 0, p; do q_idx = 0, n; do l_idx = 0, m local_inv_ds = 1._wp/dz(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) @@ -1357,13 +1366,13 @@ contains local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx - 1) rhs_vf_arg(advxb)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(advxb)%sf(l_idx, q_idx, & - & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if else ! NOT alt_soundspeed $:GPU_PARALLEL_LOOP(collapse=4, private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & - & local_flux1, local_flux2]') + & local_flux1, local_flux2]') do j_adv = advxb, advxe do k_idx = 0, p; do q_idx = 0, n; do l_idx = 0, m local_inv_ds = 1._wp/dz(k_idx) @@ -1371,17 +1380,21 @@ contains local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx) local_flux2 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx - 1) rhs_vf_arg(j_adv)%sf(l_idx, q_idx, k_idx) = rhs_vf_arg(j_adv)%sf(l_idx, q_idx, & - & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) + & k_idx) + local_inv_ds*local_term_coeff*(local_flux1 - local_flux2) end do; end do; end do end do $:END_GPU_PARALLEL_LOOP() end if end if end select + end subroutine s_add_directional_advection_source_terms + end subroutine s_compute_advection_source_term + !> @brief Adds viscous, surface-tension, and species-diffusion source flux contributions to the RHS for a given direction. subroutine s_compute_additional_physics_rhs(idir, q_prim_vf, rhs_vf, flux_src_n_in, dq_prim_dx_vf, dq_prim_dy_vf, dq_prim_dz_vf) + integer, intent(in) :: idir type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf @@ -1397,7 +1410,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dx(j)*q_prim_vf(c_idx)%sf(j, k, & - & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j - 1, k, l)) + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j - 1, k, l)) end do end do end do @@ -1413,7 +1426,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)*(flux_src_n_in(i)%sf(j - 1, k, & - & l) - flux_src_n_in(i)%sf(j, k, l)) + & l) - flux_src_n_in(i)%sf(j, k, l)) end do end if @@ -1421,12 +1434,13 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dx(j)*(flux_src_n_in(i)%sf(j - 1, k, & - & l) - flux_src_n_in(i)%sf(j, k, l)) + & l) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + 1._wp/dx(j)*(flux_src_n_in(E_idx)%sf(j - 1, k, l) - flux_src_n_in(E_idx)%sf(j, k, l)) + & l) + 1._wp/dx(j)*(flux_src_n_in(E_idx)%sf(j - 1, k, l) - flux_src_n_in(E_idx)%sf(j, & + & k, l)) end if end if end do @@ -1442,7 +1456,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dy(k)*q_prim_vf(c_idx)%sf(j, k, & - & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k - 1, l)) + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k - 1, l)) end do end do end do @@ -1453,12 +1467,14 @@ contains if (viscous .or. dummy) then if (p > 0) then call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & - & idwbuff(1), idwbuff(2), idwbuff(3)) + & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & + & dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & + & idwbuff(1), idwbuff(2), idwbuff(3)) else call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & - & idwbuff(1), idwbuff(2), idwbuff(3)) + & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & + & dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & + & idwbuff(1), idwbuff(2), idwbuff(3)) end if $:GPU_PARALLEL_LOOP(private='[i, j, l]', collapse=2) @@ -1467,7 +1483,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, 0, l) = rhs_vf(i)%sf(j, 0, l) + 1._wp/(y_cc(1) - y_cc(-1))*(tau_Re_vf(i)%sf(j, & - & -1, l) - tau_Re_vf(i)%sf(j, 1, l)) + & -1, l) - tau_Re_vf(i)%sf(j, 1, l)) end do end do end do @@ -1481,7 +1497,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, k - 1, & - & l) - flux_src_n_in(i)%sf(j, k, l)) + & l) - flux_src_n_in(i)%sf(j, k, l)) end do end do end do @@ -1498,7 +1514,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, & - & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) + & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) end do end if @@ -1506,12 +1522,12 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dy(k)*(flux_src_n_in(i)%sf(j, & - & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) + & k - 1, l) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + 1._wp/dy(k)*(flux_src_n_in(E_idx)%sf(j, k - 1, l) - flux_src_n_in(E_idx)%sf(j, & - & k, l)) + & l) + 1._wp/dy(k)*(flux_src_n_in(E_idx)%sf(j, k - 1, & + & l) - flux_src_n_in(E_idx)%sf(j, k, l)) end if end if end do @@ -1521,8 +1537,7 @@ contains end if end if - ! Applying the geometrical viscous Riemann source fluxes calculated as average - ! of values at cell boundaries + ! Applying the geometrical viscous Riemann source fluxes calculated as average of values at cell boundaries if (cyl_coord) then if ((bc_y%beg == -2) .or. (bc_y%beg == -14)) then $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) @@ -1532,7 +1547,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - 5.e-1_wp/y_cc(k)*(flux_src_n_in(i)%sf(j, & - & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) + & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) end do end do end do @@ -1560,7 +1575,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) - 5.e-1_wp/y_cc(k)*(flux_src_n_in(i)%sf(j, & - & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) + & k - 1, l) + flux_src_n_in(i)%sf(j, k, l)) end do end do end do @@ -1576,7 +1591,7 @@ contains do k = 0, n do j = 0, m rhs_vf(c_idx)%sf(j, k, l) = rhs_vf(c_idx)%sf(j, k, l) + 1._wp/dz(l)*q_prim_vf(c_idx)%sf(j, k, & - & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k, l - 1)) + & l)*(flux_src_n_in(advxb)%sf(j, k, l) - flux_src_n_in(advxb)%sf(j, k, l - 1)) end do end do end do @@ -1592,7 +1607,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = momxb, E_idx rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_src_n_in(i)%sf(j, k, & - & l - 1) - flux_src_n_in(i)%sf(j, k, l)) + & l - 1) - flux_src_n_in(i)%sf(j, k, l)) end do end if @@ -1600,11 +1615,12 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe rhs_vf(i)%sf(j, k, l) = rhs_vf(i)%sf(j, k, l) + 1._wp/dz(l)*(flux_src_n_in(i)%sf(j, k, & - & l - 1) - flux_src_n_in(i)%sf(j, k, l)) + & l - 1) - flux_src_n_in(i)%sf(j, k, l)) end do if (.not. viscous) then rhs_vf(E_idx)%sf(j, k, l) = rhs_vf(E_idx)%sf(j, k, & - & l) + 1._wp/dz(l)*(flux_src_n_in(E_idx)%sf(j, k, l - 1) - flux_src_n_in(E_idx)%sf(j, k, l)) + & l) + 1._wp/dz(l)*(flux_src_n_in(E_idx)%sf(j, k, l - 1) - flux_src_n_in(E_idx)%sf(j, & + & k, l)) end if end if end do @@ -1619,17 +1635,19 @@ contains do k = 0, n do j = 0, m rhs_vf(momxb + 1)%sf(j, k, l) = rhs_vf(momxb + 1)%sf(j, k, l) + 5.e-1_wp*(flux_src_n_in(momxe)%sf(j, & - & k, l - 1) + flux_src_n_in(momxe)%sf(j, k, l)) + & k, l - 1) + flux_src_n_in(momxe)%sf(j, k, l)) rhs_vf(momxe)%sf(j, k, l) = rhs_vf(momxe)%sf(j, k, l) - 5.e-1_wp*(flux_src_n_in(momxb + 1)%sf(j, k, & - & l - 1) + flux_src_n_in(momxb + 1)%sf(j, k, l)) + & l - 1) + flux_src_n_in(momxb + 1)%sf(j, k, l)) end do end do end do $:END_GPU_PARALLEL_LOOP() end if end if + end subroutine s_compute_additional_physics_rhs + !> The purpose of this subroutine is to WENO-reconstruct the left and the right cell-boundary values, including values at the !! Gaussian quadrature points, from the cell-averaged variables. !! @param v_vf Cell-average variables @@ -1641,14 +1659,16 @@ contains !! @param vR_z Right reconstructed cell-boundary values in z !! @param norm_dir Splitting coordinate direction subroutine s_reconstruct_cell_boundary_values(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_x, vR_y, vR_z - integer, intent(in) :: norm_dir - integer :: recon_dir !< Coordinate direction of the reconstruction - integer :: i, j, k, l + integer, intent(in) :: norm_dir + integer :: recon_dir !< Coordinate direction of the reconstruction + integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] + if (recon_type == ${TYPE}$ .or. dummy) then ! Reconstruction in s1-direction if (norm_dir == 1) then @@ -1668,31 +1688,36 @@ contains if (n > 0) then if (p > 0) then call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:, & - & iv%beg:iv%end), recon_dir, is1, is2, is3) + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & + & :, iv%beg:iv%end), recon_dir, is1, is2, is3) else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, is1, is2, is3) + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & + & recon_dir, is1, is2, is3) end if else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & - & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1, is2, is3) + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1, is2, is3) end if end if #:endfor + end subroutine s_reconstruct_cell_boundary_values + !> @brief Performs first-order (piecewise constant) reconstruction of left and right cell-boundary values. subroutine s_reconstruct_cell_boundary_values_first_order(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_x, vR_y, vR_z - integer, intent(in) :: norm_dir - integer :: recon_dir !< Coordinate direction of the WENO reconstruction - integer :: i, j, k, l + integer, intent(in) :: norm_dir + integer :: recon_dir !< Coordinate direction of the WENO reconstruction + integer :: i, j, k, l ! Reconstruction in s1-direction #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl', 'MUSCL_TYPE')] + if (recon_type == ${TYPE}$ .or. dummy) then if (norm_dir == 1) then is1 = idwbuff(1); is2 = idwbuff(2); is3 = idwbuff(3) @@ -1752,9 +1777,12 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_reconstruct_cell_boundary_values_first_order + !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_rhs_module + integer :: i, j, l call s_finalize_pressure_relaxation_module @@ -1913,5 +1941,7 @@ contains @:DEALLOCATE(flux_n, flux_src_n, flux_gsrc_n) end if + end subroutine s_finalize_rhs_module + end module m_rhs diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 46809ff412..aa9c86624b 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -9,14 +9,15 @@ #:include 'inline_riemann.fpp' module m_riemann_solvers - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion !< State variables type conversion procedures - use m_bubbles !< To get the bubble wall pressure function + use m_bubbles !< To get the bubble wall pressure function use m_bubbles_EE - use m_surface_tension !< To get the capillary fluxes - use m_helper_basic !< Functions to compare floating point numbers + use m_surface_tension !< To get the capillary fluxes + use m_helper_basic !< Functions to compare floating point numbers 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 @@ -34,7 +35,6 @@ module m_riemann_solvers !! direct evaluation of source terms, by using the left and right states given in qK_prim_rs_vf, dqK_prim_ds_vf where ds = dx, !! dy or dz. !> @{ - real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf, flux_src_rsx_vf real(wp), allocatable, dimension(:,:,:,:) :: flux_rsy_vf, flux_src_rsy_vf real(wp), allocatable, dimension(:,:,:,:) :: flux_rsz_vf, flux_src_rsz_vf @@ -44,15 +44,14 @@ module m_riemann_solvers !> The cell-boundary values of the geometrical source flux that are computed through the chosen Riemann problem solver by using !! the left and right states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. !> @{ - real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsx_vf real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsy_vf real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsz_vf $:GPU_DECLARE(create='[flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf]') !> @} - ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as - ! part of Riemann problem solution and is used to evaluate the source flux. + ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as part of Riemann problem solution and is used to + ! evaluate the source flux. real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsx_vf real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsy_vf @@ -82,6 +81,7 @@ module m_riemann_solvers 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 @@ -109,37 +109,42 @@ contains !! @param iy Index bounds in the y-dir !! @param iz Index bounds in the z-dir subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & + & qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & - & q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz #:for NAME, NUM in [('hll', 1), ('hllc', 2), ('hlld', 4), ('lf', 5)] + if (riemann_solver == ${NUM}$) then call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & + & dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, & + & flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) end if #:endfor + end subroutine s_riemann_solver !> Dispatch to the subroutines that are utilized to compute the viscous source fluxes for either Cartesian or cylindrical !! geometries. For more information please refer to: 1) s_compute_cartesian_viscous_source_flux 2) !! s_compute_cylindrical_viscous_source_flux subroutine s_compute_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, dvelR_dy_vf, & + & dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) type(scalar_field), dimension(num_vels), intent(in) :: velL_vf, velR_vf, dvelL_dx_vf, dvelR_dx_vf, dvelL_dy_vf, & - & dvelR_dy_vf, dvelL_dz_vf, dvelR_dz_vf + & dvelR_dy_vf, dvelL_dz_vf, dvelR_dz_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf integer, intent(in) :: norm_dir @@ -147,24 +152,26 @@ contains if (grid_geometry == 3) then call s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & - & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) + & dvelR_dy_vf, dvelR_dz_vf, flux_src_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, norm_dir) + & dvelR_dz_vf, flux_src_vf, norm_dir) end if + end subroutine s_compute_viscous_source_flux !> @brief Computes intercell fluxes using the Harten-Lax-van Leer (HLL) approximate Riemann solver. subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -226,24 +233,28 @@ contains 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 + ! Populating the buffers of the left and right Riemann problem states variables, based on the choice of boundary conditions + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & + & 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 in [(1, 'x'), (2, 'y'), (3, 'z')] 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]') + & 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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -442,7 +453,7 @@ contains & + pres_mag%R ! includes magnetic energy H_L = (E_L + pres_L - pres_mag%L)/rho_L H_R = (E_R + pres_R - pres_mag%R) & - & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 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 @@ -469,8 +480,7 @@ contains do i = 1, strxe - strxb + 1 tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - ! Elastic contribution to energy if G large enough - ! TODO take out if statement if stable without + ! 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) @@ -483,51 +493,31 @@ contains end do end if - ! elastic energy update - ! if ( hyperelasticity ) then - ! G_L = 0._wp - ! G_R = 0._wp + ! elastic energy update if ( hyperelasticity ) 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 - ! ! Elastic contribution to energy if G large enough - ! if ((G_L > 1.e-3_wp) .and. (G_R > 1.e-3_wp)) then - ! E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - ! E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) - ! $:GPU_LOOP(parallelism='[seq]') - ! do i = 1, b_size-1 - ! tau_e_L(i) = G_L*qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - ! tau_e_R(i) = G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - ! end do - ! $:GPU_LOOP(parallelism='[seq]') - ! do i = 1, b_size-1 - ! tau_e_L(i) = 0._wp - ! tau_e_R(i) = 0._wp - ! end do - ! $:GPU_LOOP(parallelism='[seq]') - ! do i = 1, num_dims - ! xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - ! xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - ! end do - ! end if - ! end if + ! $: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 ! Elastic contribution to energy if G large enough if ((G_L > 1.e-3_wp) + ! .and. (G_R > 1.e-3_wp)) then E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) E_R = E_R + + ! G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size-1 + ! tau_e_L(i) = G_L*qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) tau_e_R(i) = G_R*qR_prim_rs${XYZ}$_vf(j + ! + 1, k, l, strxb - 1 + i) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size-1 tau_e_L(i) = 0._wp + ! tau_e_R(i) = 0._wp end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims xi_field_L(i) = + ! qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - + ! 1 + i) end do end if end if @:compute_average_state() call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, c_L, & - & qv_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) + & 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) + & 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) @@ -550,16 +540,18 @@ contains s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) else if (hypoelasticity) then s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & - & /rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1)))/rho_R)) + & /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)) + & /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)) + & 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)) + & 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) @@ -572,19 +564,19 @@ contains 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)))) + & - 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 == 2) 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 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))))) + & 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))))) + & 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 @@ -595,9 +587,9 @@ contains 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)) + & 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)) + & s_R)) ! Low Mach correction if (low_Mach == 1) then @@ -611,15 +603,16 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i)*vel_L(norm_dir) & - & + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) + & 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, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i)*vel_L(norm_dir) & - & + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i)))/(s_M - s_P) + & 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 @@ -627,52 +620,54 @@ contains 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 of rho*v_i in the ${XYZ}$ direction = rho * v_i * v_${XYZ}$ - B_i * B_${XYZ}$ + + ! delta_(${XYZ}$,i) * p_tot flux_rs${XYZ}$_vf(j, k, l, & - & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) + dir_flg(i) & - & *(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) - B%L(i)*B%L(norm_dir) & - & + dir_flg(i)*(pres_L + pres_mag%L)) + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M & - & - s_P) + & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) & + & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & + & - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) end do 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 of m_i in the ${XYZ}$ direction = m_i * v_${XYZ}$ - b_i/Gamma * B_${XYZ}$ + + ! delta_(${XYZ}$,i) * p_tot flux_rs${XYZ}$_vf(j, k, l, & - & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) + dir_flg(i) & - & *(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) - b4%L(i)/Ga%L*B%L(norm_dir) & - & + dir_flg(i)*(pres_L + pres_mag%L)) + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) + & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) & + & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) & + & - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) end do else if (bubbles_euler) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L) & - & *(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do else if (hypoelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L - tau_e_L(dir_idx_tau(i))) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & + & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & + & *pres_L - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) end do else $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_L) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) & - & - vel_L(dir_idx(i))) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do end if @@ -681,22 +676,23 @@ contains ! 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_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1) & - & *B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) - s_P*(vel_L(norm_dir)*(E_L + pres_L & - & + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - & + s_M*s_P*(E_L - E_R))/(s_M - s_P) + & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & + & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + & - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir) & + & *(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) #:endif else if (mhd .and. relativity) then - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now + ! energy flux = m_${XYZ}$ - mass flux Hard-coded for single-component for now flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) - s_P*(cm%L(norm_dir) & - & - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) else if (bubbles_euler) then flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) - s_P*vel_L(dir_idx(1))*(E_L & - & + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*(vel_R_rms - vel_L_rms)/2._wp + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + & - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M & + & - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then flux_tau_L = 0._wp; flux_tau_R = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -705,20 +701,23 @@ contains flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) end do flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) - s_P*(vel_L(dir_idx(1))*(E_L & - & + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R)) & + & /(s_M - s_P) else flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & - & + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & + & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R_rms - vel_L_rms)/2._wp end if ! Elastic Stresses if (hypoelasticity) then do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow flux_rs${XYZ}$_vf(j, k, l, & - & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) - s_P*(rho_L*vel_L(dir_idx(1) & - & )*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) - rho_R*tau_e_R(i)))/(s_M - s_P) + & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & + & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & + & - rho_R*tau_e_R(i)))/(s_M - s_P) end do end if @@ -726,9 +725,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = (qL_prim_rs${XYZ}$_vf(j, k, l, i) - qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, i))*s_M*s_P/(s_M - s_P) + & k, l, i))*s_M*s_P/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) + & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) end do if (bubbles_euler) then @@ -745,48 +744,48 @@ contains Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) + & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if if (mhd) then if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. - ! B_y flux = v_x * B_y - v_y * Bx0 - ! B_z flux = v_x * B_z - v_z * Bx0 + ! 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, & - & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) - s_P*(vel_L(1) & - & *B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) + & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & + & - B%R(2 + i)))/(s_M - s_P) end do else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction - ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) - ! B_y d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) - ! B_z d/d${XYZ}$ flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) + ! 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_rs${XYZ}$_vf(j, k, l, & - & B_idx%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) + & B_idx%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_rs${XYZ}$_vf(j, k, l, B_idx%beg + norm_dir - 1) = flux_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + norm_dir - 1) + (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & psi_idx) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx))/(s_M - s_P) + & B_idx%beg + norm_dir - 1) + (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & psi_idx) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx))/(s_M - s_P) flux_rs${XYZ}$_vf(j, k, l, & - & psi_idx) = (hyper_cleaning_speed**2*(s_M*B%R(norm_dir) - s_P*B%L(norm_dir)) & - & + s_M*s_P*(qL_prim_rs${XYZ}$_vf(j, k, l, psi_idx) - qR_prim_rs${XYZ}$_vf(j + 1, k, & - & l, psi_idx)))/(s_M - s_P) + & psi_idx) = (hyper_cleaning_speed**2*(s_M*B%R(norm_dir) & + & - s_P*B%L(norm_dir)) + s_M*s_P*(qL_prim_rs${XYZ}$_vf(j, k, l, & + & psi_idx) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, psi_idx)))/(s_M - s_P) else flux_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + norm_dir - 1) & - & = 0._wp ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero + & B_idx%beg + norm_dir - 1) & + & = 0._wp ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero end if end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -801,7 +800,7 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + & contxe + 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 = advxb, advxe @@ -812,7 +811,7 @@ contains if (cyl_coord .and. hypoelasticity) then ! += tau_sigmasigma using HLL flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) + & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) $:GPU_LOOP(parallelism='[seq]') do i = strxb, strxe @@ -830,31 +829,35 @@ contains if (viscous .or. dummy) then if (weno_Re_flux) then call s_compute_viscous_source_flux(qL_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & - & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), qR_prim_vf(momxb:momxe), & - & dqR_prim_dx_vf(momxb:momxe), dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & + & qR_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & + & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) else call s_compute_viscous_source_flux(q_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & - & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), q_prim_vf(momxb:momxe), & - & dqR_prim_dx_vf(momxb:momxe), dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & + & q_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & + & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) end if end if call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + end subroutine s_hll_riemann_solver !> @brief Computes intercell fluxes using the Lax-Friedrichs (LF) approximate Riemann solver. subroutine s_lf_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -919,24 +922,27 @@ contains 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 + ! Populating the buffers of the left and right Riemann problem states variables, based on the choice of boundary conditions + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & + & 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 in [(1, 'x'), (2, 'y'), (3, 'z')] 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]') + & 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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -1133,7 +1139,7 @@ contains & + pres_mag%R ! includes magnetic energy H_L = (E_L + pres_L - pres_mag%L)/rho_L H_R = (E_R + pres_R - pres_mag%R) & - & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 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 @@ -1159,8 +1165,7 @@ contains do i = 1, strxe - strxb + 1 tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - ! Elastic contribution to energy if G large enough - ! TODO take out if statement if stable without + ! 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) @@ -1174,10 +1179,10 @@ contains 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) + & 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) + & qv_R) if (mhd) then call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) @@ -1213,15 +1218,16 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i)*vel_L(norm_dir) & - & + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) + & 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, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i)*vel_L(norm_dir) & - & + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i)))/(s_M - s_P) + & 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 @@ -1229,52 +1235,54 @@ contains 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 of rho*v_i in the ${XYZ}$ direction = rho * v_i * v_${XYZ}$ - B_i * B_${XYZ}$ + + ! delta_(${XYZ}$,i) * p_tot flux_rs${XYZ}$_vf(j, k, l, & - & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) + dir_flg(i) & - & *(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) - B%L(i)*B%L(norm_dir) & - & + dir_flg(i)*(pres_L + pres_mag%L)) + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M & - & - s_P) + & contxe + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i)*B%R(norm_dir) & + & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & + & - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) end do 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 of m_i in the ${XYZ}$ direction = m_i * v_${XYZ}$ - b_i/Gamma * B_${XYZ}$ + + ! delta_(${XYZ}$,i) * p_tot flux_rs${XYZ}$_vf(j, k, l, & - & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) + dir_flg(i) & - & *(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) - b4%L(i)/Ga%L*B%L(norm_dir) & - & + dir_flg(i)*(pres_L + pres_mag%L)) + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) + & contxe + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i)/Ga%R*B%R(norm_dir) & + & + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i)*vel_L(norm_dir) & + & - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) end do else if (bubbles_euler) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L) & - & *(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do else if (hypoelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L - tau_e_L(dir_idx_tau(i))) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & + & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & + & *pres_L - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) end do else $:GPU_LOOP(parallelism='[seq]') do i = 1, num_vels flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_L) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) & - & - vel_L(dir_idx(i))) + & contxe + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do end if @@ -1283,22 +1291,23 @@ contains ! 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_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1) & - & *B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) - s_P*(vel_L(norm_dir)*(E_L + pres_L & - & + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - & + s_M*s_P*(E_L - E_R))/(s_M - s_P) + & E_idx) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & + & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + & - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir) & + & *(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) #:endif else if (mhd .and. relativity) then - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now + ! energy flux = m_${XYZ}$ - mass flux Hard-coded for single-component for now flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) - s_P*(cm%L(norm_dir) & - & - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + & E_idx) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L & + & - E_R))/(s_M - s_P) else if (bubbles_euler) then flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) - s_P*vel_L(dir_idx(1))*(E_L & - & + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*(vel_R_rms - vel_L_rms)/2._wp + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + & - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M & + & - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then flux_tau_L = 0._wp; flux_tau_R = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -1307,20 +1316,23 @@ contains flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) end do flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) - s_P*(vel_L(dir_idx(1))*(E_L & - & + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + & E_idx) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R)) & + & /(s_M - s_P) else flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & - & + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + & E_idx) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & + & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R_rms - vel_L_rms)/2._wp end if ! Elastic Stresses if (hypoelasticity) then do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow flux_rs${XYZ}$_vf(j, k, l, & - & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) - s_P*(rho_L*vel_L(dir_idx(1) & - & )*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) - rho_R*tau_e_R(i)))/(s_M - s_P) + & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & + & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & + & - rho_R*tau_e_R(i)))/(s_M - s_P) end do end if @@ -1328,9 +1340,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = (qL_prim_rs${XYZ}$_vf(j, k, l, i) - qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, i))*s_M*s_P/(s_M - s_P) + & k, l, i))*s_M*s_P/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) + & i) - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i))/(s_M - s_P) end do if (bubbles_euler) then @@ -1347,32 +1359,33 @@ contains Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) flux_rs${XYZ}$_vf(j, k, l, & - & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) + & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do end if if (mhd) then if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. - ! B_y flux = v_x * B_y - v_y * Bx0 - ! B_z flux = v_x * B_z - v_z * Bx0 + ! 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, & - & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) - s_P*(vel_L(1) & - & *B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) + & B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & + & - B%R(2 + i)))/(s_M - s_P) end do else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction - ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) - ! B_y d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) - ! B_z d/d${XYZ}$ flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) + ! 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_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + i) = (1 - dir_flg(i + 1))*(s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i & - & + 1)*B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir) & - & ) + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + & B_idx%beg + i) = (1 - dir_flg(i + 1))*(s_M*(vel_R(dir_idx(1))*B%R(i & + & + 1) - vel_R(i + 1)*B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) & + & - vel_L(i + 1)*B%L(norm_dir)) + s_M*s_P*(B%L(i + 1) - B%R(i + 1))) & + & /(s_M - s_P) end do end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -1387,7 +1400,7 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + & contxe + 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 = advxb, advxe @@ -1398,7 +1411,7 @@ contains if (cyl_coord .and. hypoelasticity) then ! += tau_sigmasigma using HLL flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) + & contxe + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) $:GPU_LOOP(parallelism='[seq]') do i = strxb, strxe @@ -1415,7 +1428,7 @@ contains if (viscous .or. dummy) 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]') + & 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 @@ -1484,18 +1497,18 @@ contains do i = 1, num_dims vel_grad_L(i, 1) = (dqL_prim_dx_vf(momxb + i - 1)%sf(j, k, l)/Re_L(1)) vel_grad_R(i, 1) = (dqR_prim_dx_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), & - & idx_right_phys(3))/Re_R(1)) + & 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(momxb + i - 1)%sf(j, k, l)/Re_L(1)) vel_grad_R(i, 2) = (dqR_prim_dy_vf(momxb + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(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(momxb + i - 1)%sf(j, k, l)/Re_L(1)) vel_grad_R(i, 3) = (dqR_prim_dz_vf(momxb + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) + & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) end if #:endif #:endif @@ -1503,36 +1516,38 @@ contains if (norm_dir == 1) then flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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)) + & 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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)) + & 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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 @@ -1540,65 +1555,67 @@ contains else if (norm_dir == 2) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%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)) + & 2) + vel_grad_R(1, 2)) - 0.5_wp*(vel_grad_L(2, 1) + vel_grad_R(2, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 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)) + & 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%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)) + & 3) + vel_grad_R(1, 3)) - 0.5_wp*(vel_grad_L(3, 1) + vel_grad_R(3, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 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)) + & 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(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%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)) + & 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 @@ -1608,41 +1625,41 @@ contains do i = 1, num_dims vel_grad_L(i, 1) = (dqL_prim_dx_vf(momxb + i - 1)%sf(j, k, l)/Re_L(2)) vel_grad_R(i, 1) = (dqR_prim_dx_vf(momxb + i - 1)%sf(idx_right_phys(1), idx_right_phys(2), & - & idx_right_phys(3))/Re_R(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(momxb + i - 1)%sf(j, k, l)/Re_L(2)) vel_grad_R(i, 2) = (dqR_prim_dy_vf(momxb + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + & 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(momxb + i - 1)%sf(j, k, l)/Re_L(2)) vel_grad_R(i, 3) = (dqR_prim_dz_vf(momxb + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) end if #:endif end do if (norm_dir == 1) then flux_src_vf(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1) + vel_grad_R(1, 1)) + & 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1)*vel_L(1) + vel_grad_R(1, 1)*vel_R(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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & - & 2) + vel_grad_R(2, 2)) + & 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & - & 2)*vel_L(1) + vel_grad_R(2, 2)*vel_R(1)) + & 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(momxb)%sf(j, k, l) = flux_src_vf(momxb)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(1) + vel_grad_R(3, 3)*vel_R(1)) + & 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 @@ -1650,40 +1667,40 @@ contains else if (norm_dir == 2) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1)*vel_L(2) + vel_grad_R(1, 1)*vel_R(2)) + & 1)*vel_L(2) + vel_grad_R(1, 1)*vel_R(2)) flux_src_vf(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & - & 2)*vel_L(2) + vel_grad_R(2, 2)*vel_R(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(momxb + 1)%sf(j, k, l) = flux_src_vf(momxb + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(2) + vel_grad_R(3, 3)*vel_R(2)) + & 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(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1)*vel_L(3) + vel_grad_R(1, 1)*vel_R(3)) + & 1)*vel_L(3) + vel_grad_R(1, 1)*vel_R(3)) flux_src_vf(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(2, & - & 2)*vel_L(3) + vel_grad_R(2, 2)*vel_R(3)) + & 2)*vel_L(3) + vel_grad_R(2, 2)*vel_R(3)) flux_src_vf(momxb + 2)%sf(j, k, l) = flux_src_vf(momxb + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - 0.5_wp*(vel_grad_L(3, & - & 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) + & 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) #:endif end if end if @@ -1694,6 +1711,7 @@ contains end if call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + end subroutine s_lf_riemann_solver !> This procedure is the implementation of the Harten, Lax, van Leer, and contact (HLLC) approximate Riemann solver, see Toro @@ -1722,15 +1740,16 @@ contains !! @param iy Index bounds in the y-dir !! @param iz Index bounds in the z-dir subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -1811,12 +1830,12 @@ contains 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 + ! Populating the buffers of the left and right Riemann problem states variables, based on the choice of boundary conditions call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & + & norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction @@ -1828,13 +1847,17 @@ contains if (model_eqns == 3) then ! ME3 $: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_MP, xi_PP]') + & 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_MP, xi_PP]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -1874,7 +1897,7 @@ contains do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, & - & E_idx + i)), 1._wp) + & E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) end do @@ -1882,16 +1905,16 @@ contains do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, E_idx + i)), 1._wp) + & k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, & - & E_idx + i)/max(alpha_L_sum, sgm_eps) + & E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & E_idx + i)/max(alpha_R_sum, sgm_eps) + & E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -1991,15 +2014,15 @@ contains @: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) + & 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) + & 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) + & 0._wp, c_avg, qv_avg) if (viscous) then $:GPU_LOOP(parallelism='[seq]') @@ -2017,23 +2040,23 @@ contains if (wave_speeds == 1) then if (elasticity) then s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & - & ))/rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & - & /rho_R)) + & ))/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)) + & ))/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)))) + & + 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)))) + & - 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 == 2) 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)))) @@ -2041,11 +2064,11 @@ contains pres_SR = pres_SL 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))))) + & 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))))) + & 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 @@ -2053,35 +2076,31 @@ contains 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) + ! 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) ) + ! goes with q_star_L/R = xi_L/R * (variable) xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) - ! goes with numerical star velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + ! 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)) + ! 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)) + & - 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))))) + & + 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))) + & - vel_R(dir_idx(1))) ! Low Mach correction if (low_Mach == 1) then @@ -2090,27 +2109,25 @@ contains pcorr = 0._wp end if - ! COMPUTING FLUXES - ! MASS FLUX. + ! COMPUTING FLUXES MASS FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do - ! MOMENTUM FLUX. - ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + ! 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_rs${XYZ}$_vf(j, k, l, & - & contxe + 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 + & contxe + 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)) + ! ENERGY FLUX. f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_star + p_Star)*vel_K_Star + (s_M/s_L)*(s_P/s_R)*pcorr*s_S ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux @@ -2120,12 +2137,14 @@ contains do i = 1, num_dims ! MOMENTUM ELASTIC FLUX. flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) + & contxe + 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)))))) + & + 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_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e end if @@ -2134,34 +2153,37 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*s_S + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S + & i)*s_S + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S end do ! SOURCE TERM FOR VOLUME FRACTION ADVECTION FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_MP*(xi_L - 1) + 1) & - & - vel_L(dir_idx(i)))) + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_PP*(xi_R & - & - 1) + 1) - vel_R(dir_idx(i)))) + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & + & *(s_S*(xi_MP*(xi_L - 1) + 1) - vel_L(dir_idx(i)))) & + & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*(s_S*(xi_PP*(xi_R - 1) & + & + 1) - vel_R(dir_idx(i)))) end do - ! INTERNAL ENERGIES ADVECTION FLUX. - ! K-th pressure and velocity in preparation for the internal energy flux + ! 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) + & + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_L) + pres_L) & + & + xi_P*(xi_PP*((pres_R + pi_infs(i)/(1._wp + gammas(i))) & + & *xi_R**(1._wp/gammas(i) + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_R) & + & + pres_R) flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = ((xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i + advxb - 1))*(gammas(i)*p_K_Star + pi_infs(i)) + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i + contxb - 1))*qvs(i))*vel_K_Star + (s_M/s_L)*(s_P/s_R) & - & *pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) + & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i + advxb - 1))*(gammas(i)*p_K_Star + pi_infs(i)) & + & + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i + contxb - 1))*qvs(i))*vel_K_Star + (s_M/s_L)*(s_P/s_R) & + & *pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & + & i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) end do flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) @@ -2171,9 +2193,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, strxe - strxb + 1 flux_rs${XYZ}$_vf(j, k, l, & - & strxb - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & - & - rho_L*vel_L(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)) + & strxb - 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 @@ -2182,16 +2204,16 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & xibeg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - & - rho_L*vel_L(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)) + & xibeg - 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_rs${XYZ}$_vf(j, k, l, c_idx) = (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & c_idx) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S + & c_idx) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S end if ! Geometrical source flux for cylindrical coordinates @@ -2208,7 +2230,7 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb - 1 + dir_idx(1)) - p_Star + & momxb - 1 + dir_idx(1)) - p_Star ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -2223,7 +2245,7 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb - 1 + dir_idx(1)) - p_Star + & momxb - 1 + dir_idx(1)) - p_Star flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if @@ -2235,12 +2257,13 @@ contains else if (model_eqns == 4) then ! ME4 $: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_MP, xi_PP]') + & 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_MP, xi_PP]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -2300,35 +2323,35 @@ contains @: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) + & 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) + & 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) + & 0._wp, c_avg, qv_avg) if (wave_speeds == 1) then s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & - & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L - vel_L(dir_idx(1))) & - & - rho_R*(s_R - vel_R(dir_idx(1)))) + & - 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 == 2) 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 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))))) + & 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))))) + & 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 @@ -2336,37 +2359,34 @@ contains 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) + ! 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) ) + ! goes with q_star_L/R = xi_L/R * (variable) xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + ! 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, contxe flux_rs${XYZ}$_vf(j, k, l, & - & i) = xi_M*alpha_rho_L(i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*alpha_rho_R(i) & - & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i) = xi_M*alpha_rho_L(i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*alpha_rho_R(i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do - ! Momentum flux. - ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + ! 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_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i)))*vel_L(dir_idx(i))) & - & - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_L) + xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(i)) + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_R) + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_L) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_R) end do if (bubbles_euler) then @@ -2374,8 +2394,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) + xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & - & + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) + & contxe + dir_idx(i)) + xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & + & + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) end do end if @@ -2384,8 +2404,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = alf_idx, alf_idx ! only advect the void fraction flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation @@ -2402,8 +2422,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = bubxb, bubxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j & - & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do end if @@ -2418,11 +2439,12 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) + xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -2437,11 +2459,12 @@ contains flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp end do flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) - xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -2451,12 +2474,13 @@ contains $:END_GPU_PARALLEL_LOOP() else if (model_eqns == 2 .and. bubbles_euler) then $: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_MP, xi_PP, nbub_L, nbub_R, PbwR3Lbar, PbwR3Rbar, & - & R3Lbar, R3Rbar, R3V2Lbar, R3V2Rbar]') + & 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_MP, xi_PP, nbub_L, nbub_R, PbwR3Lbar, PbwR3Rbar, R3Lbar, R3Rbar, & + & R3V2Lbar, R3V2Rbar]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -2531,9 +2555,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 1, Re_size(i) Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res_gs(i, & - & q) + Re_L(i) + & q) + Re_L(i) Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, & - & q)))/Res_gs(i, q) + Re_R(i) + & q)))/Res_gs(i, q) + Re_R(i) end do Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) @@ -2641,15 +2665,15 @@ contains 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) + & 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) + & 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) + & 0._wp, c_avg, qv_avg) if (viscous) then $:GPU_LOOP(parallelism='[seq]') @@ -2668,19 +2692,19 @@ contains 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)))) + & - 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 == 2) 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 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))))) + & 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))))) + & 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 @@ -2688,17 +2712,14 @@ contains 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) + ! 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) ) + ! goes with q_star_L/R = xi_L/R * (variable) xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + ! 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)) @@ -2712,8 +2733,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do if (bubbles_euler .and. (num_fluids > 1)) then @@ -2721,8 +2742,7 @@ contains flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp end if - ! Momentum flux. - ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + ! Momentum flux. f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) ! Include p_tilde @@ -2743,36 +2763,38 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i)))*vel_L(dir_idx(i))) & - & - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) + xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(i)) + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) + (s_M/s_L) & - & *(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) & + & + (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)) + ! Energy flux. f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = xi_M*(vel_L(dir_idx(1))*(E_L + pres_L) + 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 + & E_idx) = 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 = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! Source for volume fraction advection equation $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L - 1._wp)) & - & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R - 1._wp)) + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L & + & - 1._wp)) + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R & + & - 1._wp)) ! IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp end do @@ -2783,20 +2805,21 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = bubxb, bubxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do if (qbmm) then flux_rs${XYZ}$_vf(j, k, l, & - & bubxb) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & bubxb) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if if (adv_n) then flux_rs${XYZ}$_vf(j, k, l, & - & n_idx) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & n_idx) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if ! Geometrical source flux for cylindrical coordinates @@ -2809,11 +2832,12 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) + xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -2829,11 +2853,12 @@ contains end do flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) - xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -2844,12 +2869,15 @@ contains else ! 5-EQUATION MODEL WITH HLLC $: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, 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]') + & 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, 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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -2877,17 +2905,16 @@ contains pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - ! Change this by splitting it into the cases - ! present in the bubbles_euler + ! 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_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, & - & E_idx + i)), 1._wp) + & E_idx + i)), 1._wp) qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, & - & k, l, E_idx + i)), 1._wp) + & k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do @@ -2895,9 +2922,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, & - & E_idx + i)/max(alpha_L_sum, sgm_eps) + & E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & E_idx + i)/max(alpha_R_sum, sgm_eps) + & E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -3058,15 +3085,15 @@ contains @: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) + & 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) + & 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) + & c_sum_Yi_Phi, c_avg, qv_avg) if (viscous) then if (chemistry) then @@ -3086,23 +3113,23 @@ contains if (wave_speeds == 1) then if (elasticity) then s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & - & ))/rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & - & /rho_R)) + & ))/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)) + & ))/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)))) + & + 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)))) + & - 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 == 2) 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)))) @@ -3110,11 +3137,11 @@ contains pres_SR = pres_SL 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))))) + & 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))))) + & 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 @@ -3122,17 +3149,14 @@ contains 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) + ! 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) ) + ! goes with q_star_L/R = xi_L/R * (variable) xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + ! 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)) @@ -3143,35 +3167,34 @@ contains pcorr = 0._wp end if - ! COMPUTING THE HLLC FLUXES - ! MASS FLUX. + ! COMPUTING THE HLLC FLUXES MASS FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do - ! MOMENTUM FLUX. - ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + ! 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_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i)))*vel_L(dir_idx(i))) & - & - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) + xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(i)) + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) + (s_M/s_L) & - & *(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + & contxe + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) & + & + (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)) + ! ENERGY FLUX. f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) flux_rs${XYZ}$_vf(j, k, l, & - & E_idx) = xi_M*(vel_L(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 + & E_idx) = 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 ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux if (elasticity) then @@ -3180,12 +3203,14 @@ contains do i = 1, num_dims ! MOMENTUM ELASTIC FLUX. flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = flux_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(i)) - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) + & contxe + 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)))))) + & + 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_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e end if @@ -3195,9 +3220,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, strxe - strxb + 1 flux_rs${XYZ}$_vf(j, k, l, & - & strxb - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & - & - rho_L*vel_L(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)) + & strxb - 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 @@ -3205,23 +3230,25 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & + & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do ! VOLUME FRACTION SOURCE FLUX. $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L - 1._wp)) & - & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R - 1._wp)) + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*(xi_L & + & - 1._wp)) + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*(xi_R & + & - 1._wp)) end do ! COLOR FUNCTION FLUX if (surface_tension) then flux_rs${XYZ}$_vf(j, k, l, c_idx) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & - & c_idx)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, & - & l, c_idx)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & c_idx)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, & + & c_idx)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if ! REFERENCE MAP FLUX. @@ -3229,9 +3256,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims flux_rs${XYZ}$_vf(j, k, l, & - & xibeg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - & - rho_L*vel_L(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)) + & xibeg - 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 @@ -3244,8 +3271,8 @@ contains Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) flux_rs${XYZ}$_vf(j, k, l, & - & i) = xi_M*rho_L*Y_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - & + xi_P*rho_R*Y_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + & i) = xi_M*rho_L*Y_L*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + & + xi_P*rho_R*Y_R*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) flux_src_rs${XYZ}$_vf(j, k, l, i) = 0.0_wp end do end if @@ -3260,11 +3287,12 @@ contains end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) + xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & contxe + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) ! Geometrical source of the void fraction(s) is zero $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe @@ -3280,11 +3308,12 @@ contains end do flux_gsrc_rs${XYZ}$_vf(j, k, l, & - & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & - & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) - xi_P*(rho_R*(vel_R(dir_idx(1)) & - & *vel_R(dir_idx(1)) + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + & momxb + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1)) & + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) end if #:endif @@ -3300,35 +3329,39 @@ contains if (viscous .or. dummy) then if (weno_Re_flux) then call s_compute_viscous_source_flux(qL_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & - & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), qR_prim_vf(momxb:momxe), & - & dqR_prim_dx_vf(momxb:momxe), dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & + & qR_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & + & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) else call s_compute_viscous_source_flux(q_prim_vf(momxb:momxe), dqL_prim_dx_vf(momxb:momxe), & - & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), q_prim_vf(momxb:momxe), & - & dqR_prim_dx_vf(momxb:momxe), dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf(momxb:momxe), dqL_prim_dz_vf(momxb:momxe), & + & q_prim_vf(momxb:momxe), dqR_prim_dx_vf(momxb:momxe), & + & dqR_prim_dy_vf(momxb:momxe), dqR_prim_dz_vf(momxb:momxe), flux_src_vf, & + & norm_dir, ix, iy, iz) end if end if if (surface_tension) then call s_compute_capillary_source_flux(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf, flux_src_vf, norm_dir, isx, isy, & - & isz) + & isz) end if call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + end subroutine s_hllc_riemann_solver !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: 1 entropy wave, 2 Alfven waves, 2 fast magnetosonic waves. subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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 @@ -3355,9 +3388,9 @@ contains real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) - ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction - ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction + ! 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 @@ -3365,18 +3398,20 @@ contains integer :: i, j, k, l call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & + & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & + & norm_dir, ix, iy, iz) call s_initialize_riemann_solver(flux_src_vf, norm_dir) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] 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]') + & 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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -3407,15 +3442,16 @@ contains if (mhd) then if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, & - & B_idx%beg + 1)] + & B_idx%beg + 1)] B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, & - & B_idx%beg + 1)] + & B_idx%beg + 1)] else ! 2D/3D: Bx, By, Bz as variables B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), qL_prim_rs${XYZ}$_vf(j, k, & - & l, B_idx%beg + dir_idx(2) - 1), qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] + & l, B_idx%beg + dir_idx(2) - 1), qL_prim_rs${XYZ}$_vf(j, k, l, & + & B_idx%beg + dir_idx(3) - 1)] B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & - & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & - & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] + & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & + & qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] end if end if @@ -3441,13 +3477,13 @@ contains E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L H_no_mag%R = (E%R + pres%R - pres_mag%R) & - & /rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) ! (2) Compute fast wave speeds call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, & - & 0._wp, c%L, qv%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) + & 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) @@ -3459,7 +3495,7 @@ contains 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)) + & - 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) @@ -3503,14 +3539,14 @@ contains 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 + & - 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 + & - 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 + & + 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 + & + 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, & @@ -3533,8 +3569,7 @@ contains F_hlld = F_R end if - ! (12) Reorder and write temporary variables to the flux array - ! Mass + ! (12) Reorder and write temporary variables to the flux array Mass flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component ! Momentum flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = F_hlld(2) @@ -3565,14 +3600,15 @@ contains #:endfor call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + end subroutine s_hlld_riemann_solver !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_riemann_solvers_module - ! Allocating the variables that will be utilized to formulate the - ! left, right, and average states of the Riemann problem, as well - ! the Riemann problem solution + + ! Allocating the variables that will be utilized to formulate the left, right, and average states of the Riemann problem, as + ! well the Riemann problem solution integer :: i, j @:ALLOCATE(Gs_rs(1:num_fluids)) @@ -3647,6 +3683,7 @@ contains if (viscous) then @:ALLOCATE(Re_avg_rsz_vf(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:2)) end if + end subroutine s_initialize_riemann_solvers_module !> The purpose of this subroutine is to populate the buffers of the left and right Riemann states variables, depending on the @@ -3668,18 +3705,20 @@ contains !! @param iy Index bounds in the y-dir !! @param iz Index bounds in the z-dir subroutine s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & - & dqR_prim_dz_vf, norm_dir, ix, iy, iz) + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + & 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/) @@ -3996,6 +4035,7 @@ contains end if end if ! END: Population of Buffers in z-direction + end subroutine s_populate_riemann_states_variables_buffers !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other @@ -4003,6 +4043,7 @@ contains !! @param flux_src_vf Intra-cell fluxes sources !! @param norm_dir Dir. splitting 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 @@ -4147,25 +4188,27 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if + end subroutine s_initialize_riemann_solver !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. Calculates Cartesian components of the !! stress tensor using averaged velocity derivatives and cylindrical geometric factors, then updates `flux_src_vf`. Assumes !! x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). - !! @param[in] velL_vf Left boundary velocity (\f$v_x, v_y, v_z\f$) (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary \f$\partial v_i/\partial x\f$ (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary \f$\partial v_i/\partial y\f$ (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary \f$\partial v_i/\partial z\f$ (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity (\f$v_x, v_y, v_z\f$) (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary \f$\partial v_i/\partial x\f$ (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary \f$\partial v_i/\partial y\f$ (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary \f$\partial v_i/\partial z\f$ (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x-face, 2=y-face, 3=z-face). - !! @param[in] ix Global X-direction loop bounds (int_bounds_info). - !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). + !! @param[in] velL_vf Left boundary velocity (\f$v_x, v_y, v_z\f$) (num_dims scalar_field). + !! @param[in] dvelL_dx_vf Left boundary \f$\partial v_i/\partial x\f$ (num_dims scalar_field). + !! @param[in] dvelL_dy_vf Left boundary \f$\partial v_i/\partial y\f$ (num_dims scalar_field). + !! @param[in] dvelL_dz_vf Left boundary \f$\partial v_i/\partial z\f$ (num_dims scalar_field). + !! @param[in] velR_vf Right boundary velocity (\f$v_x, v_y, v_z\f$) (num_dims scalar_field). + !! @param[in] dvelR_dx_vf Right boundary \f$\partial v_i/\partial x\f$ (num_dims scalar_field). + !! @param[in] dvelR_dy_vf Right boundary \f$\partial v_i/\partial y\f$ (num_dims scalar_field). + !! @param[in] dvelR_dz_vf Right boundary \f$\partial v_i/\partial z\f$ (num_dims scalar_field). + !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). + !! @param[in] norm_dir Interface normal direction (1=x-face, 2=y-face, 3=z-face). + !! @param[in] ix Global X-direction loop bounds (int_bounds_info). + !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). + !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & + & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf @@ -4183,20 +4226,21 @@ contains 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. + real(wp), & - & dimension(3) & - & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + & dimension(3) & + & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). #:else real(wp), & - & dimension(num_dims) :: avg_v_int !!< Averaged interface velocity (\f$v_x, v_y, v_z\f$) (grid directions). + & 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). real(wp), & - & dimension(num_dims) :: vel_src_int !!< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. + & dimension(num_dims) :: vel_src_int !!< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. real(wp), & - & dimension(num_dims) & - & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + & dimension(num_dims) & + & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). #: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. @@ -4208,7 +4252,7 @@ contains integer :: idx_rp(3) !!< Indices \f$(j,k,l)\f$ of 'right' point for averaging. $: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]') + & vel_src_int, r_eff, divergence_cyl, stress_vector_shear, stress_normal_bulk, div_v_term_const]') do l = iz%beg, iz%end do k = iy%beg, iy%end do j = ix%beg, ix%end @@ -4216,23 +4260,23 @@ contains 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) + ! 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))) + & 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))) + & 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))) + & idx_rp(2), idx_rp(3))) else avg_dvdz_int(i_vel) = 0.0_wp end if @@ -4294,7 +4338,7 @@ contains 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 + & )/Re_s #:endif end if #:endif @@ -4307,7 +4351,7 @@ contains 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 + & + div_v_term_const #:endif end if end select @@ -4315,9 +4359,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i_vel = 1, num_dims flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, & - & l) - stress_vector_shear(i_vel) + & l) - stress_vector_shear(i_vel) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) + & l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) end do end if @@ -4325,13 +4369,14 @@ contains stress_normal_bulk = divergence_cyl/Re_b flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, & - & l) - stress_normal_bulk + & l) - stress_normal_bulk flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk end if end do end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_compute_cylindrical_viscous_source_flux !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. Calculates averaged velocity gradients, @@ -4345,6 +4390,7 @@ contains !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). 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, norm_dir) ! Arguments @@ -4375,8 +4421,9 @@ contains 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. + $: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]') + & vel_src_at_interface, Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx]') do l_loop = isz%beg, isz%end do k_loop = isy%beg, isy%end do j_loop = isx%beg, isx%end @@ -4388,19 +4435,20 @@ contains 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))) + & 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))) + & 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))) + & 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 @@ -4437,10 +4485,10 @@ contains do i_dim = 1, num_dims flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = flux_src_vf(momxb + i_dim - 1)%sf(j_loop, & - & k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + & k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = flux_src_vf(E_idx)%sf(j_loop, k_loop, & - & l_loop) - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + & l_loop) - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) end do end if @@ -4450,16 +4498,17 @@ contains do i_dim = 1, num_dims flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = flux_src_vf(momxb + i_dim - 1)%sf(j_loop, & - & k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + & k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = flux_src_vf(E_idx)%sf(j_loop, k_loop, & - & l_loop) - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + & 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 !> @brief Calculates shear stress tensor components. tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear @@ -4468,6 +4517,7 @@ contains !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + $:GPU_ROUTINE(parallelism='[seq]') ! Arguments @@ -4494,6 +4544,7 @@ contains end if end do end do + end subroutine s_calculate_shear_stress_tensor !> @brief Calculates bulk stress tensor components (diagonal only). tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. @@ -4501,6 +4552,7 @@ contains !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + $:GPU_ROUTINE(parallelism='[seq]') ! Arguments @@ -4519,18 +4571,21 @@ contains 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 + !> Deallocation and/or disassociation procedures that are needed to finalize the selected Riemann problem solver !! @param flux_vf Intercell fluxes !! @param flux_src_vf Intercell source fluxes !! @param flux_gsrc_vf Intercell geometric source fluxes !! @param norm_dir Dimensional splitting coordinate direction 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 @@ -4668,10 +4723,12 @@ contains $: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 + if (viscous) then @:DEALLOCATE(Re_avg_rsx_vf) end if @@ -4708,5 +4765,7 @@ contains if (qbmm) then @:DEALLOCATE(mom_sp_rsz_vf) end if + end subroutine s_finalize_riemann_solvers_module + end module m_riemann_solvers diff --git a/src/simulation/m_sim_helpers.fpp b/src/simulation/m_sim_helpers.fpp index 655dee9f29..897bf8ea90 100644 --- a/src/simulation/m_sim_helpers.fpp +++ b/src/simulation/m_sim_helpers.fpp @@ -7,6 +7,7 @@ !> @brief Simulation helper routines for enthalpy computation, CFL calculation, and stability checks module m_sim_helpers + use m_derived_types !< Definitions of the derived types use m_global_parameters use m_variables_conversion @@ -14,13 +15,15 @@ module m_sim_helpers implicit none private; public :: s_compute_enthalpy, s_compute_stability_from_dt, s_compute_dt_from_cfl + contains !> Computes the modified dtheta for Fourier filtering in azimuthal direction - !! @param k y coordinate index - !! @param l z coordinate index - !! @return fltr_dtheta Modified dtheta value for cylindrical coordinates + !! @param k y coordinate index + !! @param l z coordinate index + !! @return fltr_dtheta Modified dtheta value for cylindrical coordinates function f_compute_filtered_dtheta(k, l) result(fltr_dtheta) + $:GPU_ROUTINE(parallelism='[seq]') integer, intent(in) :: k, l real(wp) :: fltr_dtheta @@ -38,16 +41,18 @@ contains else fltr_dtheta = 0._wp end if + end function f_compute_filtered_dtheta !> Computes inviscid CFL terms for multi-dimensional cases (2D/3D only) - !! @param vel directional velocities - !! @param c mixture speed of sound - !! @param j x coordinate index - !! @param k y coordinate index - !! @param l z coordinate index - !! @return cfl_terms computed CFL terms for 2D/3D cases + !! @param vel directional velocities + !! @param c mixture speed of sound + !! @param j x coordinate index + !! @param k y coordinate index + !! @param l z coordinate index + !! @return cfl_terms computed CFL terms for 2D/3D cases function f_compute_multidim_cfl_terms(vel, c, j, k, l) result(cfl_terms) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(num_vels), intent(in) :: vel real(wp), intent(in) :: c @@ -70,24 +75,26 @@ contains ! 2D cfl_terms = min(dx(j)/(abs(vel(1)) + c), dy(k)/(abs(vel(2)) + c)) end if + end function f_compute_multidim_cfl_terms !> Computes enthalpy - !! @param q_prim_vf cell centered primitive variables - !! @param pres mixture pressure - !! @param rho mixture density - !! @param gamma mixture gamma - !! @param pi_inf mixture pi_inf - !! @param Re mixture reynolds number - !! @param H mixture enthalpy - !! @param alpha component alphas - !! @param vel directional velocities - !! @param vel_sum squard sum of velocity components - !! @param qv Fluid reference energy - !! @param j x index - !! @param k y index - !! @param l z index + !! @param q_prim_vf cell centered primitive variables + !! @param pres mixture pressure + !! @param rho mixture density + !! @param gamma mixture gamma + !! @param pi_inf mixture pi_inf + !! @param Re mixture reynolds number + !! @param H mixture enthalpy + !! @param alpha component alphas + !! @param vel directional velocities + !! @param vel_sum squard sum of velocity components + !! @param qv Fluid reference energy + !! @param j x index + !! @param k y index + !! @param l z index subroutine s_compute_enthalpy(q_prim_vf, pres, rho, gamma, pi_inf, Re, H, alpha, vel, vel_sum, qv, j, k, l) + $:GPU_ROUTINE(function_name='s_compute_enthalpy',parallelism='[seq]', cray_inline=True) type(scalar_field), intent(in), dimension(sys_size) :: q_prim_vf @@ -150,20 +157,22 @@ contains end if H = (E + pres)/rho + end subroutine s_compute_enthalpy !> Computes stability criterion for a specified dt - !! @param vel directional velocities - !! @param c mixture speed of sound - !! @param rho Density - !! @param Re_l mixture Reynolds number - !! @param j x index - !! @param k y index - !! @param l z index - !! @param icfl_sf cell-centered inviscid cfl number - !! @param vcfl_sf (optional) cell-centered viscous CFL number - !! @param Rc_sf (optional) cell centered Rc + !! @param vel directional velocities + !! @param c mixture speed of sound + !! @param rho Density + !! @param Re_l mixture Reynolds number + !! @param j x index + !! @param k y index + !! @param l z index + !! @param icfl_sf cell-centered inviscid cfl number + !! @param vcfl_sf (optional) cell-centered viscous CFL number + !! @param Rc_sf (optional) cell centered Rc subroutine s_compute_stability_from_dt(vel, c, rho, Re_l, j, k, l, icfl_sf, vcfl_sf, Rc_sf) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in), dimension(num_vels) :: vel real(wp), intent(in) :: c, rho @@ -191,11 +200,11 @@ contains fltr_dtheta = f_compute_filtered_dtheta(k, l) vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/min(dx(j), dy(k), fltr_dtheta)**2._wp Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), dy(k)*(abs(vel(2)) + c), & - & fltr_dtheta*(abs(vel(3)) + c))/maxval(1._wp/Re_l) + & fltr_dtheta*(abs(vel(3)) + c))/maxval(1._wp/Re_l) else vcfl_sf(j, k, l) = maxval(dt/Re_l/rho)/min(dx(j), dy(k), dz(l))**2._wp Rc_sf(j, k, l) = min(dx(j)*(abs(vel(1)) + c), dy(k)*(abs(vel(2)) + c), & - & dz(l)*(abs(vel(3)) + c))/maxval(1._wp/Re_l) + & dz(l)*(abs(vel(3)) + c))/maxval(1._wp/Re_l) end if #:endif else if (n > 0) then @@ -208,18 +217,20 @@ contains Rc_sf(j, k, l) = dx(j)*(abs(vel(1)) + c)/maxval(1._wp/Re_l) end if end if + end subroutine s_compute_stability_from_dt !> Computes dt for a specified CFL number - !! @param vel directional velocities - !! @param c Speed of sound - !! @param max_dt cell centered maximum dt - !! @param rho cell centered density - !! @param Re_l cell centered Reynolds number - !! @param j x coordinate - !! @param k y coordinate - !! @param l z coordinate + !! @param vel directional velocities + !! @param c Speed of sound + !! @param max_dt cell centered maximum dt + !! @param rho cell centered density + !! @param Re_l cell centered Reynolds number + !! @param j x coordinate + !! @param k y coordinate + !! @param l z coordinate subroutine s_compute_dt_from_cfl(vel, c, max_dt, rho, Re_l, j, k, l) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(num_vels), intent(in) :: vel real(wp), intent(in) :: c, rho @@ -262,5 +273,7 @@ contains else max_dt(j, k, l) = icfl_dt end if + end subroutine s_compute_dt_from_cfl + end module m_sim_helpers diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 404c5ca971..4148a48424 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -7,31 +7,32 @@ !> @brief Reads input files, loads initial conditions and grid data, and orchestrates solver initialization and finalization module m_start_up - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_mpi_common use m_variables_conversion !< State variables type conversion procedures - use m_weno !< Weighted and essentially non-oscillatory (WENO) schemes for spatial reconstruction of variables - use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for convservation laws - use m_riemann_solvers !< Exact and approximate Riemann problem solvers - use m_cbc !< Characteristic boundary conditions (CBC) + use m_weno !< Weighted and essentially non-oscillatory (WENO) schemes for spatial reconstruction of variables + use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for convservation laws + use m_riemann_solvers !< Exact and approximate Riemann problem solvers + use m_cbc !< Characteristic boundary conditions (CBC) use m_boundary_common - use m_acoustic_src !< Acoustic source calculations - use m_rhs !< Right-hand-side (RHS) evaluation procedures - use m_chemistry !< Chemistry module - use m_data_output !< Run-time info & solution data output procedures - use m_time_steppers !< Time-stepping algorithms - use m_qbmm !< Quadrature MOM - use m_derived_variables !< Procedures used to compute quantities derived from the conservative and primitive variables + use m_acoustic_src !< Acoustic source calculations + use m_rhs !< Right-hand-side (RHS) evaluation procedures + use m_chemistry !< Chemistry module + use m_data_output !< Run-time info & solution data output procedures + use m_time_steppers !< Time-stepping algorithms + use m_qbmm !< Quadrature MOM + use m_derived_variables !< Procedures used to compute quantities derived from the conservative and primitive variables use m_hypoelastic use m_hyperelastic - use m_phase_change !< Phase-change module + use m_phase_change !< Phase-change module use m_viscous - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL !< Lagrange bubble dynamics routines + use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines + use m_bubbles_EL !< Lagrange bubble dynamics routines use ieee_arithmetic - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic !< Functions to compare floating point numbers use m_helper $:USE_GPU_MODULE() @@ -54,11 +55,13 @@ module m_start_up type(scalar_field), allocatable, dimension(:) :: q_cons_temp real(wp) :: dt_init + contains !> Read data files. Dispatch subroutine that replaces procedure pointer. - !! @param q_cons_vf Conservative variables + !! @param q_cons_vf Conservative variables impure subroutine s_read_data_files(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf if (.not. parallel_io) then @@ -66,20 +69,23 @@ contains else call s_read_parallel_data_files(q_cons_vf) end if + end subroutine s_read_data_files !> The purpose of this procedure is to first verify that an input file has been made available by the user. Provided that this !! is so, the input file is then read in. impure subroutine s_read_input_file + ! Relative path to the input file provided by the user character(LEN=name_len), parameter :: file_path = './simulation.inp' logical :: file_exist !< Logical used to check the existence of the input file integer :: iostatus - !! Integer to check iostat of file read + !! Integer to check iostat of file read character(len=1000) :: line ! Namelist of the global parameters which may be specified by user + namelist /user_inputs/ case_dir, run_time_info, m, n, p, dt, & t_step_start, t_step_stop, t_step_save, t_step_print, & model_eqns, mpp_lim, time_stepper, weno_eps, & @@ -111,8 +117,8 @@ contains & hyper_cleaning, hyper_cleaning_speed, hyper_cleaning_tau, alf_factor, num_igr_iters, num_igr_warm_start_iters, & & int_comp, ic_eps, ic_beta, nv_uvm_out_of_core, nv_uvm_igr_temps_on_gpu, nv_uvm_pref_gpu, down_sample, fft_wrt - ! Checking that an input file has been provided by the user. If it - ! has, then the input file is read in, otherwise, simulation exits. + ! Checking that an input file has been provided by the user. If it has, then the input file is read in, otherwise, + ! simulation exits. inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then @@ -147,11 +153,13 @@ contains else call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if + end subroutine s_read_input_file !> The goal of this procedure is to verify that each of the user provided inputs is valid and that their combination constitutes !! a meaningful configuration for the simulation. impure subroutine s_check_input_file + ! Relative path to the current directory file in the case directory character(LEN=path_len) :: file_path @@ -159,6 +167,7 @@ contains logical :: file_exist ! Logistics + file_path = trim(case_dir) // '/.' call my_inquire(file_path, file_exist) @@ -169,20 +178,23 @@ contains call s_check_inputs_common() call s_check_inputs() + end subroutine s_check_input_file !> @brief Reads serial initial condition and grid data files and computes cell-width distributions. - !! @param q_cons_vf Cell-averaged conservative variables + !! @param q_cons_vf Cell-averaged conservative variables impure subroutine s_read_serial_data_files(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the starting time-step directory - character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files - logical :: file_exist + character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the starting time-step directory + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files + logical :: file_exist ! Logical used to check the existence of the data files integer :: i, r !< Generic loop iterator - ! Confirming that the directory from which the initial condition and - ! the grid data files are to be read in exists and exiting otherwise + ! Confirming that the directory from which the initial condition and the grid data files are to be read in exists and + ! exiting otherwise + if (cfl_dt) then write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all/p', proc_rank, '/', n_start else @@ -221,7 +233,7 @@ contains do i = 1, num_ibs if (patch_ib(i)%c > 0) then Np = int((patch_ib(i)%p*patch_ib(i)%c/dx(0))*20) + int(((patch_ib(i)%c - patch_ib(i)%p*patch_ib(i)%c)/dx(0)) & - & *20) + 1 + & *20) + 1 end if end do end if @@ -300,11 +312,13 @@ contains end do end if end if + end subroutine s_read_serial_data_files !> @brief Reads parallel initial condition and grid data files via MPI I/O. - !! @param q_cons_vf Conservative variables + !! @param q_cons_vf Conservative variables impure subroutine s_read_parallel_data_files(q_cons_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf #ifdef MFC_MPI @@ -365,7 +379,7 @@ contains do i = 1, num_ibs if (patch_ib(i)%c > 0) then Np = int((patch_ib(i)%p*patch_ib(i)%c/dx(0))*20) + int(((patch_ib(i)%c - patch_ib(i)%p*patch_ib(i)%c)/dx(0)) & - & *20) + 1 + & *20) + 1 allocate (MPI_IO_airfoil_IB_DATA%var(1:2*Np)) end if end do @@ -583,12 +597,14 @@ contains call s_assign_default_bc_type(bc_type) end if #endif + end subroutine s_read_parallel_data_files !> The purpose of this procedure is to initialize the values of the internal-energy equations of each phase from the mass of !! each phase, the mixture momentum and mixture-total-energy equations. - !! @param v_vf conservative variables + !! @param v_vf conservative variables subroutine s_initialize_internal_energy_equations(v_vf) + type(scalar_field), dimension(sys_size), intent(inout) :: v_vf real(wp) :: rho real(wp) :: dyn_pres @@ -626,24 +642,26 @@ contains pres_mag = 0.5_wp*(Bx0**2 + v_vf(B_idx%beg)%sf(j, k, l)**2 + v_vf(B_idx%beg + 1)%sf(j, k, l)**2) else pres_mag = 0.5_wp*(v_vf(B_idx%beg)%sf(j, k, l)**2 + v_vf(B_idx%beg + 1)%sf(j, k, & - & l)**2 + v_vf(B_idx%beg + 2)%sf(j, k, l)**2) + & l)**2 + v_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if end if call s_compute_pressure(v_vf(E_idx)%sf(j, k, l), 0._stp, dyn_pres, pi_inf, gamma, rho, qv, rhoYks, pres, T, & - & pres_mag=pres_mag) + & pres_mag=pres_mag) do i = 1, num_fluids v_vf(i + intxb - 1)%sf(j, k, l) = v_vf(i + advxb - 1)%sf(j, k, & - & l)*(gammas(i)*pres + pi_infs(i)) + v_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) + & l)*(gammas(i)*pres + pi_infs(i)) + v_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) end do end do end do end do + end subroutine s_initialize_internal_energy_equations !> @brief Advances the simulation by one time step, handling CFL-based dt and time-stepper dispatch. impure subroutine s_perform_time_step(t_step, time_avg) + integer, intent(inout) :: t_step real(wp), intent(inout) :: time_avg integer :: i @@ -701,10 +719,12 @@ contains ! Time-stepping loop controls t_step = t_step + 1 + end subroutine s_perform_time_step !> @brief Collects per-process wall-clock times and writes aggregate performance metrics to file. impure subroutine s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & + & file_exists) real(wp), intent(inout) :: time_avg, time_final @@ -734,7 +754,7 @@ contains end if grind_time = time_final*1.0e9_wp/(real(sys_size, wp)*real(maxval((/1, m_glb/)), wp)*real(maxval((/1, n_glb/)), & - & wp)*real(maxval((/1, p_glb/)), wp)) + & wp)*real(maxval((/1, p_glb/)), wp)) print *, "Performance:", grind_time, "ns/gp/eq/rhs" inquire (FILE='time_data.dat', EXIST=file_exists) @@ -760,10 +780,12 @@ contains write (1, '(I10, F15.8)') num_procs, io_time_final close (1) end if + end subroutine s_save_performance_metrics !> @brief Saves conservative variable data to disk at the current time step. impure subroutine s_save_data(t_step, start, finish, io_time_avg, nt) + integer, intent(inout) :: t_step real(wp), intent(inout) :: start, finish, io_time_avg integer, intent(inout) :: nt @@ -823,7 +845,7 @@ contains if (bubbles_lagrange) then $:GPU_UPDATE(host='[lag_id, mtn_pos, mtn_posPrev, mtn_vel, intfc_rad, intfc_vel, bub_R0, Rmax_stats, Rmin_stats, & - & bub_dphidt, gas_p, gas_mv, gas_mg, gas_betaT, gas_betaC]') + & bub_dphidt, gas_p, gas_mv, gas_mg, gas_betaT, gas_betaC]') do i = 1, nBubs if (ieee_is_nan(intfc_rad(i, 1)) .or. intfc_rad(i, 1) <= 0._wp) then call s_mpi_abort("Bubble radius is negative or NaN, please reduce dt.") @@ -852,10 +874,12 @@ contains else io_time_avg = (abs(finish - start) + io_time_avg*(nt - 1))/nt end if + end subroutine s_save_data !> @brief Initializes all simulation sub-modules in the required dependency order. impure subroutine s_initialize_modules + integer :: m_ds, n_ds, p_ds integer :: i, j, k, l, x_id, y_id, z_id, ix, iy, iz real(wp) :: temp1, temp2, temp3, temp4 @@ -864,11 +888,11 @@ contains #:if USING_AMD #: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. adv_idx%end > 20 .and. (.not. chemistry), & - & "CBC module with AMD compiler requires adv_idx%end <= 20 when case optimization is turned off") + & bc_z%end/) == ${BC}$) .and. adv_idx%end > 20 .and. (.not. chemistry), & + & "CBC module with AMD compiler requires adv_idx%end <= 20 when case optimization is turned off") @:PROHIBIT(any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, & - & bc_z%end/) == ${BC}$) .and. sys_size > 20 .and. (chemistry), & - & "CBC module with AMD compiler and chemistry requires sys_size <= 20 when case optimization is turned off") + & bc_z%end/) == ${BC}$) .and. sys_size > 20 .and. (chemistry), & + & "CBC module with AMD compiler and chemistry requires sys_size <= 20 when case optimization is turned off") #:endfor #:endif if (bubbles_euler .or. bubbles_lagrange) then @@ -943,9 +967,8 @@ contains ! Initialize the Temperature cache. if (chemistry) call s_compute_q_T_sf(q_T_sf, q_cons_ts(1)%vf, idwint) - ! Computation of parameters, allocation of memory, association of pointers, - ! and/or execution of any other tasks that are needed to properly configure - ! the modules. The preparations below DO DEPEND on the grid being complete. + ! Computation of parameters, allocation of memory, association of pointers, and/or execution of any other tasks that are + ! needed to properly configure the modules. The preparations below DO DEPEND on the grid being complete. if (igr .or. dummy) then call s_initialize_igr_module() end if @@ -964,10 +987,12 @@ contains if (hypoelasticity) call s_initialize_hypoelastic_module() if (hyperelasticity) call s_initialize_hyperelastic_module() + end subroutine s_initialize_modules !> @brief Sets up the MPI execution environment, binds GPUs, and decomposes the computational domain. impure subroutine s_initialize_mpi_domain + integer :: ierr #ifdef MFC_GPU real(wp) :: starttime, endtime @@ -1008,10 +1033,9 @@ contains #endif #endif - ! The rank 0 processor assigns default values to the user inputs prior to - ! reading them in from the input file. Next, the user inputs are read and - ! their consistency is checked. The identification of any inconsistencies - ! will result in the termination of the simulation. + ! The rank 0 processor assigns default values to the user inputs prior to reading them in from the input file. Next, the + ! user inputs are read and their consistency is checked. The identification of any inconsistencies will result in the + ! termination of the simulation. if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() @@ -1033,21 +1057,23 @@ contains #endif end if - ! Broadcasting the user inputs to all of the processors and performing the - ! parallel computational domain decomposition. Neither procedure has to be - ! carried out if the simulation is in fact not truly executed in parallel. + ! Broadcasting the user inputs to all of the processors and performing the parallel computational domain decomposition. + ! Neither procedure has to be carried out if the simulation is in fact not truly executed in parallel. call s_mpi_bcast_user_inputs() call s_initialize_parallel_io() call s_mpi_decompose_computational_domain() + end subroutine s_initialize_mpi_domain !> @brief Transfers initial conservative variable and model parameter data to the GPU device. subroutine s_initialize_gpu_vars + integer :: i ! Update GPU DATA + if (.not. down_sample) then do i = 1, sys_size $:GPU_UPDATE(device='[q_cons_ts(1)%vf(i)%sf]') @@ -1064,9 +1090,10 @@ contains $:GPU_UPDATE(device='[chem_params]') $:GPU_UPDATE(device='[R0ref, p0ref, rho0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, R_v, R_g, Tw, cp_v, & - & cp_g, k_vl, k_gl, gam, gam_m, Eu, Ca, Web, Re_inv, Pe_c, phi_vg, phi_gv, omegaN, bubbles_euler, polytropic, & - & polydisperse, qbmm, ptil, bubble_model, thermal, poly_sigma, adv_n, adap_dt, adap_dt_tol, adap_dt_max_iters, n_idx, & - & pi_fac, low_Mach]') + & cp_g, k_vl, k_gl, gam, gam_m, Eu, Ca, Web, Re_inv, Pe_c, phi_vg, phi_gv, omegaN, bubbles_euler, polytropic, & + & polydisperse, qbmm, ptil, bubble_model, thermal, poly_sigma, adv_n, adap_dt, adap_dt_tol, & + & adap_dt_max_iters, & + & n_idx, pi_fac, low_Mach]') if (bubbles_euler) then $:GPU_UPDATE(device='[weight, R0]') @@ -1110,10 +1137,12 @@ contains $:GPU_UPDATE(device='[molecular_weights_nonparameter]') end block #:endif + end subroutine s_initialize_gpu_vars !> @brief Finalizes and deallocates all simulation sub-modules in reverse initialization order. impure subroutine s_finalize_modules + call s_finalize_time_steppers_module() if (hypoelasticity) call s_finalize_hypoelastic_module() if (hyperelasticity) call s_finalize_hyperelastic_module() @@ -1148,5 +1177,7 @@ contains ! Terminating MPI execution environment call s_mpi_finalize() + end subroutine s_finalize_modules + end module m_start_up diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index 88fc6d6fc6..52cffffd54 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -8,12 +8,13 @@ !> @brief Computes capillary source fluxes and color-function gradients for the diffuse-interface surface tension model module m_surface_tension - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_variables_conversion use m_weno - use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws + use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws use m_helper use m_boundary_common @@ -36,9 +37,11 @@ module m_surface_tension type(int_bounds_info) :: is1, is2, is3, iv $:GPU_DECLARE(create='[is1, is2, is3, iv]') + contains impure subroutine s_initialize_surface_tension_module + integer :: j @:ALLOCATE(c_divs(1:num_dims + 1)) @@ -56,14 +59,16 @@ contains if (p > 0) then @:ALLOCATE(gL_z(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & - & num_dims + 1)) + & num_dims + 1)) @:ALLOCATE(gR_z(idwbuff(3)%beg:idwbuff(3)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(1)%beg:idwbuff(1)%end, & - & num_dims + 1)) + & num_dims + 1)) end if + end subroutine s_initialize_surface_tension_module !> @brief Computes the capillary (surface-tension) source flux from reconstructed color-gradient fields. subroutine s_compute_capillary_source_flux(vSrc_rsx_vf, vSrc_rsy_vf, vSrc_rsz_vf, flux_src_vf, id, isx, isy, isz) + real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsx_vf real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsy_vf real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsz_vf @@ -109,11 +114,11 @@ contains flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(1, i) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(1, i)*vSrc_rsx_vf(j, k, & - & l, i) + & l, i) end do flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + sigma*c_divs(num_dims + 1)%sf(j, k, & - & l)*vSrc_rsx_vf(j, k, l, 1) + & l)*vSrc_rsx_vf(j, k, l, 1) end if end do end do @@ -150,11 +155,11 @@ contains flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(2, i) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(2, i)*vSrc_rsy_vf(k, & - & j, l, i) + & j, l, i) end do flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsy_vf(k, j, l, 2) + & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsy_vf(k, j, l, 2) end if end do end do @@ -192,11 +197,11 @@ contains flux_src_vf(momxb + i - 1)%sf(j, k, l) = flux_src_vf(momxb + i - 1)%sf(j, k, l) + Omega(3, i) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + Omega(3, i)*vSrc_rsz_vf(l, & - & k, j, i) + & k, j, i) end do flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & - & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsz_vf(l, k, j, 3) + & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsz_vf(l, k, j, 3) end if end do end do @@ -204,10 +209,12 @@ contains $:END_GPU_PARALLEL_LOOP() #:endif end if + end subroutine s_compute_capillary_source_flux !> @brief Computes color-function gradients and their norms, then reconstructs them at cell boundaries. impure subroutine s_get_capillary(q_prim_vf, bc_type) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type type(int_bounds_info) :: isx, isy, isz @@ -225,7 +232,7 @@ contains do k = 0, n do j = 0, m c_divs(1)%sf(j, k, l) = 1._wp/(x_cc(j + 1) - x_cc(j - 1))*(q_prim_vf(c_idx)%sf(j + 1, k, & - & l) - q_prim_vf(c_idx)%sf(j - 1, k, l)) + & l) - q_prim_vf(c_idx)%sf(j - 1, k, l)) end do end do end do @@ -236,7 +243,7 @@ contains do k = 0, n do j = 0, m c_divs(2)%sf(j, k, l) = 1._wp/(y_cc(k + 1) - y_cc(k - 1))*(q_prim_vf(c_idx)%sf(j, k + 1, & - & l) - q_prim_vf(c_idx)%sf(j, k - 1, l)) + & l) - q_prim_vf(c_idx)%sf(j, k - 1, l)) end do end do end do @@ -248,7 +255,7 @@ contains do k = 0, n do j = 0, m c_divs(3)%sf(j, k, l) = 1._wp/(z_cc(l + 1) - z_cc(l - 1))*(q_prim_vf(c_idx)%sf(j, k, & - & l + 1) - q_prim_vf(c_idx)%sf(j, k, l - 1)) + & l + 1) - q_prim_vf(c_idx)%sf(j, k, l - 1)) end do end do end do @@ -264,8 +271,7 @@ contains do i = 1, num_dims c_divs(num_dims + 1)%sf(j, k, l) = c_divs(num_dims + 1)%sf(j, k, l) + c_divs(i)%sf(j, k, l)**2._wp end do - ! c_divs(num_dims + 1)%sf(j, k, l) = & - ! sqrt(c_divs(num_dims + 1)%sf(j, k, l)) + ! c_divs(num_dims + 1)%sf(j, k, l) = & sqrt(c_divs(num_dims + 1)%sf(j, k, l)) c_divs(num_dims + 1)%sf(j, k, l) = sqrt(real(c_divs(num_dims + 1)%sf(j, k, l), kind=wp)) end do end do @@ -280,18 +286,21 @@ contains do i = 1, num_dims call s_reconstruct_cell_boundary_values_capillary(c_divs, gL_x, gL_y, gL_z, gR_x, gR_y, gR_z, i) end do + end subroutine s_get_capillary !> @brief Reconstructs left and right cell-boundary values of capillary (color-gradient) variables using WENO or MUSCL. subroutine s_reconstruct_cell_boundary_values_capillary(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(out) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(out) :: vR_x, vR_y, vR_z - integer, intent(in) :: norm_dir - integer :: recon_dir !< Coordinate direction of the reconstruction - integer :: i, j, k, l + integer, intent(in) :: norm_dir + integer :: recon_dir !< Coordinate direction of the reconstruction + integer :: i, j, k, l #:for SCHEME, TYPE in [('weno', 'WENO_TYPE'),('muscl', 'MUSCL_TYPE')] + if (recon_type == ${TYPE}$ .or. dummy) then ! Reconstruction in s1-direction @@ -353,10 +362,12 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_reconstruct_cell_boundary_values_capillary !> @brief Deallocates the color-gradient divergence and reconstructed boundary arrays for surface tension. impure subroutine s_finalize_surface_tension_module + integer :: j do j = 1, num_dims @@ -371,5 +382,7 @@ contains if (p > 0) then @:DEALLOCATE(gL_z, gR_z) end if + end subroutine s_finalize_surface_tension_module + end module m_surface_tension diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 137f9d5c00..cf3cc388d6 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -7,16 +7,17 @@ !> @brief Total-variation-diminishing (TVD) Runge--Kutta time integrators (1st-, 2nd-, and 3rd-order SSP) module m_time_steppers - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_rhs !< Right-hane-side (RHS) evaluation procedures + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters + use m_rhs !< Right-hane-side (RHS) evaluation procedures use m_pressure_relaxation !< Pressure relaxation procedures - use m_data_output !< Run-time info & solution data output procedures - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL !< Lagrange bubble dynamics routines + use m_data_output !< Run-time info & solution data output procedures + use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines + use m_bubbles_EL !< Lagrange bubble dynamics routines use m_ibm use m_hyperelastic - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy !< Message passing interface (MPI) module proxy use m_boundary_common use m_helper use m_sim_helpers @@ -55,11 +56,13 @@ module m_time_steppers type(c_ptr) :: cptr_host, cptr_device #endif !> @endcond + contains !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_time_steppers_module + #ifdef FRONTIER_UNIFIED use hipfort use hipfort_hipmalloc @@ -70,6 +73,7 @@ contains #endif integer :: i, j !< Generic loop iterators ! Setting number of time-stages for selected time-stepping scheme + if (time_stepper == 1) then num_ts = 1 else if (any(time_stepper == (/2, 3/))) then @@ -94,22 +98,22 @@ contains if (num_ts == 2 .and. nv_uvm_out_of_core) then ! host allocation for q_cons_ts(2)%vf(j)%sf for all j allocate (q_cons_ts_pool_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + & idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) end if do j = 1, sys_size ! q_cons_ts(1) lives on the device @:ALLOCATE(q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(q_cons_ts(1)%vf(j)%sf) if (num_ts == 2) then if (nv_uvm_out_of_core) then ! q_cons_ts(2) lives on the host q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) else @:ALLOCATE(q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(q_cons_ts(2)%vf(j)%sf) end if end if @@ -119,8 +123,7 @@ contains @:ACC_SETUP_VFs(q_cons_ts(i)) end do #elif defined(FRONTIER_UNIFIED) - ! Allocate to memory regions using hip calls - ! that we will attach pointers to + ! Allocate to memory regions using hip calls that we will attach pointers to do i = 1, 3 pool_dims(i) = idwbuff(i)%end - idwbuff(i)%beg + 1 pool_starts(i) = idwbuff(i)%beg @@ -129,7 +132,7 @@ contains pool_starts(4) = 1 #ifdef MFC_MIXED_PRECISION pool_size = 1_8*(idwbuff(1)%end - idwbuff(1)%beg + 1)*(idwbuff(2)%end - idwbuff(2)%beg + 1)*(idwbuff(3)%end - idwbuff(3) & - & %beg + 1)*sys_size + & %beg + 1)*sys_size call hipCheck(hipMalloc_(cptr_device, pool_size*2_8)) call c_f_pointer(cptr_device, q_cons_ts_pool_device, shape=pool_dims) q_cons_ts_pool_device(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:) => q_cons_ts_pool_device @@ -144,14 +147,14 @@ contains #if defined(MFC_OpenACC) call acc_map_data(q_cons_ts_pool_device, c_loc(q_cons_ts_pool_device), c_sizeof(q_cons_ts_pool_device)) #endif - ! CCE see it can access this and will leave it on the host. It will stay on the host so long as HSA_XNACK=1 - ! NOTE: WE CANNOT DO ATOMICS INTO THIS MEMORY. We have to change a property to use atomics here - ! Otherwise leaving this as fine-grained will actually help performance since it can't be cached in GPU L2 + ! CCE see it can access this and will leave it on the host. It will stay on the host so long as HSA_XNACK=1 NOTE: WE CANNOT + ! DO ATOMICS INTO THIS MEMORY. We have to change a property to use atomics here Otherwise leaving this as fine-grained will + ! actually help performance since it can't be cached in GPU L2 if (num_ts == 2) then call hipCheck(hipMallocManaged(q_cons_ts_pool_host, dims8=pool_dims, lbounds8=pool_starts, flags=hipMemAttachGlobal)) #if defined(MFC_OpenMP) call hipCheck(hipMemAdvise(c_loc(q_cons_ts_pool_host), c_sizeof(q_cons_ts_pool_host), & - & hipMemAdviseSetPreferredLocation, -1)) + & hipMemAdviseSetPreferredLocation, -1)) #endif end if #endif @@ -159,11 +162,11 @@ contains do j = 1, sys_size ! q_cons_ts(1) lives on the device q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_device(:,:,:, j) + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_device(:,:,:, j) if (num_ts == 2) then ! q_cons_ts(2) lives on the host q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) end if end do @@ -178,7 +181,7 @@ contains do i = 1, num_ts do j = 1, sys_size @:ALLOCATE(q_cons_ts(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_cons_ts(i)) end do @@ -197,7 +200,7 @@ contains do i = 1, num_probe_ts do j = 1, sys_size @:ALLOCATE(q_prim_ts1(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_prim_ts1(i)) end do @@ -211,7 +214,7 @@ contains do i = 1, num_probe_ts do j = 1, sys_size @:ALLOCATE(q_prim_ts2(i)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) end do @:ACC_SETUP_VFs(q_prim_ts2(i)) end do @@ -223,19 +226,19 @@ contains if (.not. igr) then do i = 1, adv_idx%end @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do if (bubbles_euler) then do i = bub_idx%beg, bub_idx%end @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do if (adv_n) then @:ALLOCATE(q_prim_vf(n_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(n_idx)) end if end if @@ -243,7 +246,7 @@ contains if (mhd) then do i = B_idx%beg, B_idx%end @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if @@ -251,7 +254,7 @@ contains if (elasticity) then do i = stress_idx%beg, stress_idx%end @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if @@ -259,41 +262,41 @@ contains if (hyperelasticity) then do i = xibeg, xiend + 1 @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (cont_damage) then @:ALLOCATE(q_prim_vf(damage_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(damage_idx)) end if if (hyper_cleaning) then @:ALLOCATE(q_prim_vf(psi_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(psi_idx)) end if if (model_eqns == 3) then do i = internalEnergies_idx%beg, internalEnergies_idx%end @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do end if if (surface_tension) then @:ALLOCATE(q_prim_vf(c_idx)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(c_idx)) end if if (chemistry) then do i = chemxb, chemxe @:ALLOCATE(q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end)) + & idwbuff(3)%beg:idwbuff(3)%end)) @:ACC_SETUP_SFs(q_prim_vf(i)) end do @@ -306,26 +309,26 @@ contains ! Initialize bubble variables pb and mv at all quadrature nodes for all R0 bins if (qbmm .and. (.not. polytropic)) then @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:nnode, 1:nb)) + & 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(1)) @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:nnode, 1:nb)) + & 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(2)) @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:nnode, 1:nb)) + & 1:nnode, 1:nb)) else if (qbmm .and. polytropic) then @:ALLOCATE(pb_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & - & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(1)) @:ALLOCATE(pb_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & - & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(pb_ts(2)) @:ALLOCATE(rhs_pb(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & - & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) else @:ALLOCATE(pb_ts(1)%sf(0,0,0,0,0)) @:ACC_SETUP_SFs(pb_ts(1)) @@ -340,26 +343,26 @@ contains if (qbmm .and. (.not. polytropic)) then @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:nnode, 1:nb)) + & 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(1)) @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:nnode, 1:nb)) + & 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(2)) @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end, & - & 1:nnode, 1:nb)) + & 1:nnode, 1:nb)) else if (qbmm .and. polytropic) then @:ALLOCATE(mv_ts(1)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & - & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(1)) @:ALLOCATE(mv_ts(2)%sf(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & - & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) @:ACC_SETUP_SFs(mv_ts(2)) @:ALLOCATE(rhs_mv(idwbuff(1)%beg:idwbuff(1)%beg + 1, idwbuff(2)%beg:idwbuff(2)%beg + 1, & - & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) + & idwbuff(3)%beg:idwbuff(3)%beg + 1, 1:nnode, 1:nb)) else @:ALLOCATE(mv_ts(1)%sf(0,0,0,0,0)) @:ACC_SETUP_SFs(mv_ts(1)) @@ -447,10 +450,12 @@ contains end if $:GPU_UPDATE(device='[rk_coef, stor]') end if + end subroutine s_initialize_time_steppers_module !> @brief Advances the solution one full step using a TVD Runge-Kutta time integrator. impure subroutine s_tvd_rk(t_step, time_avg, nstage) + #ifdef _CRAYFTN ! DIR$ OPTIMIZE (-haggress) #endif @@ -469,7 +474,7 @@ contains do s = 1, nstage call s_compute_rhs(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_ts(1)%sf, rhs_pb, mv_ts(1)%sf, rhs_mv, & - & t_step, time_avg, s) + & t_step, time_avg, s) if (s == 1) then if (run_time_info) then @@ -504,10 +509,12 @@ contains end if if (igr) then q_cons_ts(1)%vf(i)%sf(j, k, l) = (rk_coef(s, 1)*q_cons_ts(1)%vf(i)%sf(j, k, l) + rk_coef(s, & - & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*rhs_vf(i)%sf(j, k, l))/rk_coef(s, 4) + & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*rhs_vf(i)%sf(j, k, & + & l))/rk_coef(s, 4) else q_cons_ts(1)%vf(i)%sf(j, k, l) = (rk_coef(s, 1)*q_cons_ts(1)%vf(i)%sf(j, k, l) + rk_coef(s, & - & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*dt*rhs_vf(i)%sf(j, k, l))/rk_coef(s, 4) + & 2)*q_cons_ts(stor)%vf(i)%sf(j, k, l) + rk_coef(s, 3)*dt*rhs_vf(i)%sf(j, k, & + & l))/rk_coef(s, 4) end if end do end do @@ -527,9 +534,9 @@ contains mv_ts(stor)%sf(j, k, l, q, i) = mv_ts(1)%sf(j, k, l, q, i) end if pb_ts(1)%sf(j, k, l, q, i) = (rk_coef(s, 1)*pb_ts(1)%sf(j, k, l, q, i) + rk_coef(s, & - & 2)*pb_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_pb(j, k, l, q, i))/rk_coef(s, 4) + & 2)*pb_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_pb(j, k, l, q, i))/rk_coef(s, 4) mv_ts(1)%sf(j, k, l, q, i) = (rk_coef(s, 1)*mv_ts(1)%sf(j, k, l, q, i) + rk_coef(s, & - & 2)*mv_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_mv(j, k, l, q, i))/rk_coef(s, 4) + & 2)*mv_ts(stor)%sf(j, k, l, q, i) + rk_coef(s, 3)*dt*rhs_mv(j, k, l, q, i))/rk_coef(s, 4) end do end do end do @@ -586,11 +593,13 @@ contains else wall_time_avg = 0._wp end if + end subroutine s_tvd_rk !> Bubble source part in Strang operator splitting scheme - !! @param stage Current time-stage + !! @param stage Current time-stage impure subroutine s_adaptive_dt_bubble(stage) + integer, intent(in) :: stage type(vector_field) :: gm_alpha_qp @@ -613,10 +622,12 @@ contains call s_write_void_evol(mytime) end if end if + end subroutine s_adaptive_dt_bubble !> @brief Computes the global time step size from CFL stability constraints across all cells. impure subroutine s_compute_dt() + real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: vel !< Cell-avg. velocity @@ -636,6 +647,7 @@ contains type(vector_field) :: gm_alpha_qp real(wp) :: dt_local integer :: j, k, l !< Generic loop iterators + if (.not. igr .or. dummy) then call s_convert_conservative_to_primitive_variables(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, idwint) end if @@ -670,13 +682,15 @@ contains end if $:GPU_UPDATE(device='[dt]') + end subroutine s_compute_dt !> This subroutine applies the body forces source term at each Runge-Kutta stage - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf_in Primitive variables - !! @param rhs_vf_in Right-hand side variables + !! @param q_cons_vf Conservative variables + !! @param q_prim_vf_in Primitive variables + !! @param rhs_vf_in Right-hand side variables subroutine s_apply_bodyforces(q_cons_vf, q_prim_vf_in, rhs_vf_in, ldt) + type(scalar_field), dimension(1:sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf_in type(scalar_field), dimension(1:sys_size), intent(inout) :: rhs_vf_in @@ -699,10 +713,12 @@ contains $:END_GPU_PARALLEL_LOOP() call nvtxEndRange + end subroutine s_apply_bodyforces !> @brief Updates immersed boundary positions and velocities at the current Runge-Kutta stage. subroutine s_propagate_immersed_boundaries(s) + integer, intent(in) :: s integer :: i logical :: forces_computed @@ -724,7 +740,7 @@ contains if (patch_ib(i)%moving_ibm > 0) then patch_ib(i)%vel = (rk_coef(s, 1)*patch_ib(i)%step_vel + rk_coef(s, 2)*patch_ib(i)%vel)/rk_coef(s, 4) patch_ib(i)%angular_vel = (rk_coef(s, 1)*patch_ib(i)%step_angular_vel + rk_coef(s, & - & 2)*patch_ib(i)%angular_vel)/rk_coef(s, 4) + & 2)*patch_ib(i)%angular_vel)/rk_coef(s, 4) if (patch_ib(i)%moving_ibm == 1) then ! plug in analytic velocities for 1-way coupling, if it exists @@ -741,38 +757,41 @@ contains ! update the angular velocity with the torque value patch_ib(i)%angular_vel = (patch_ib(i)%angular_vel*patch_ib(i)%moment) + (rk_coef(s, & - & 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum + & 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum call s_compute_moment_of_inertia(i, & - & patch_ib(i)%angular_vel) & - & ! update the moment of inertia to be based on the direction of the angular momentum + & patch_ib(i)%angular_vel) & + & ! update the moment of inertia to be based on the direction of the angular momentum patch_ib(i)%angular_vel = patch_ib(i)%angular_vel/patch_ib(i) & - & %moment ! convert back to angular velocity with the new moment of inertia + & %moment ! convert back to angular velocity with the new moment of inertia end if ! Update the angle of the IB patch_ib(i)%angles = (rk_coef(s, 1)*patch_ib(i)%step_angles + rk_coef(s, 2)*patch_ib(i)%angles + rk_coef(s, & - & 3)*patch_ib(i)%angular_vel*dt)/rk_coef(s, 4) + & 3)*patch_ib(i)%angular_vel*dt)/rk_coef(s, 4) ! Update the position of the IB patch_ib(i)%x_centroid = (rk_coef(s, 1)*patch_ib(i)%step_x_centroid + rk_coef(s, & - & 2)*patch_ib(i)%x_centroid + rk_coef(s, 3)*patch_ib(i)%vel(1)*dt)/rk_coef(s, 4) + & 2)*patch_ib(i)%x_centroid + rk_coef(s, 3)*patch_ib(i)%vel(1)*dt)/rk_coef(s, 4) patch_ib(i)%y_centroid = (rk_coef(s, 1)*patch_ib(i)%step_y_centroid + rk_coef(s, & - & 2)*patch_ib(i)%y_centroid + rk_coef(s, 3)*patch_ib(i)%vel(2)*dt)/rk_coef(s, 4) + & 2)*patch_ib(i)%y_centroid + rk_coef(s, 3)*patch_ib(i)%vel(2)*dt)/rk_coef(s, 4) patch_ib(i)%z_centroid = (rk_coef(s, 1)*patch_ib(i)%step_z_centroid + rk_coef(s, & - & 2)*patch_ib(i)%z_centroid + rk_coef(s, 3)*patch_ib(i)%vel(3)*dt)/rk_coef(s, 4) + & 2)*patch_ib(i)%z_centroid + rk_coef(s, 3)*patch_ib(i)%vel(3)*dt)/rk_coef(s, 4) end if end do call s_update_mib(num_ibs) call nvtxEndRange + end subroutine s_propagate_immersed_boundaries - !> This subroutine saves the temporary q_prim_vf vector into the q_prim_ts vector that is then used in p_main - !! @param t_step current time-step + !> This subroutine saves the temporary q_prim_vf vector into the q_prim_ts vector that is then used in p_main + !! @param t_step current time-step subroutine s_time_step_cycling(t_step) + integer, intent(in) :: t_step integer :: i, j, k, l !< Generic loop iterator + if (t_step == t_step_start) then $:GPU_PARALLEL_LOOP(collapse=4) do i = 1, sys_size @@ -837,10 +856,12 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_time_step_cycling !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_time_steppers_module + #ifdef FRONTIER_UNIFIED use hipfort use hipfort_hipmalloc @@ -849,6 +870,7 @@ contains integer :: i, j !< Generic loop iterators ! Deallocating the cell-average conservative variables #if defined(__NVCOMPILER_GPU_UNIFIED_MEM) + do j = 1, sys_size @:DEALLOCATE(q_cons_ts(1)%vf(j)%sf) if (num_ts == 2) then @@ -964,5 +986,7 @@ contains if (proc_rank == 0 .and. ib_state_wrt) then call s_close_ib_state_file() end if + end subroutine s_finalize_time_steppers_module + end module m_time_steppers diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index a208b96001..e08fd2e079 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -6,10 +6,11 @@ !> @brief Computes viscous stress tensors and diffusive flux contributions for the Navier--Stokes equations module m_viscous - use m_derived_types !< Definitions of the derived types + + use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_weno - use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws + use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws use m_helper use m_finite_differences @@ -22,11 +23,14 @@ module m_viscous real(wp), allocatable, dimension(:,:) :: Res_viscous $:GPU_DECLARE(create='[Res_viscous]') + contains !> @brief Allocates and populates the viscous Reynolds number arrays and transfers data to the GPU. impure subroutine s_initialize_viscous_module + integer :: i, j !< generic loop iterators + @:ALLOCATE(Res_viscous(1:2, 1:Re_size_max)) do i = 1, 2 @@ -36,24 +40,22 @@ contains end do $:GPU_UPDATE(device='[Res_viscous, Re_idx, Re_size]') $:GPU_ENTER_DATA(copyin='[is1_viscous, is2_viscous, is3_viscous, iv]') + end subroutine s_initialize_viscous_module !> The purpose of this subroutine is to compute the viscous - ! stress tensor for the cells directly next to the axis in - ! cylindrical coordinates. This is necessary to avoid the - ! 1/r singularity that arises at the cell boundary coinciding - ! with the axis, i.e., y_cb(-1) = 0. - ! @param q_prim_vf Cell-average primitive variables - ! @param grad_x_vf Cell-average primitive variable derivatives, x-dir - ! @param grad_y_vf Cell-average primitive variable derivatives, y-dir - ! @param grad_z_vf Cell-average primitive variable derivatives, z-dir + ! stress tensor for the cells directly next to the axis in cylindrical coordinates. This is necessary to avoid the 1/r + ! singularity that arises at the cell boundary coinciding with the axis, i.e., y_cb(-1) = 0. @param q_prim_vf Cell-average + ! primitive variables @param grad_x_vf Cell-average primitive variable derivatives, x-dir @param grad_y_vf Cell-average + ! primitive variable derivatives, y-dir @param grad_z_vf Cell-average primitive variable derivatives, z-dir subroutine s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, grad_x_vf, grad_y_vf, grad_z_vf, tau_Re_vf, ix, iy, iz) - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), dimension(num_dims), intent(in) :: grad_x_vf, grad_y_vf, grad_z_vf + + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(num_dims), intent(in) :: grad_x_vf, grad_y_vf, grad_z_vf type(scalar_field), dimension(1:sys_size), intent(inout) :: tau_Re_vf - type(int_bounds_info), intent(in) :: ix, iy, iz - real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables - real(wp), dimension(2) :: Re_visc + type(int_bounds_info), intent(in) :: ix, iy, iz + real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables + real(wp), dimension(2) :: Re_visc #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha_visc, alpha_rho_visc real(wp), dimension(3, 3) :: tau_Re @@ -63,6 +65,7 @@ contains #:endif integer :: i, j, k, l, q !< Generic loop iterator + is1_viscous = ix; is2_viscous = iy; is3_viscous = iz $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous]') @@ -83,7 +86,7 @@ contains #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 if (shear_stress) then ! Shear stresses $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & - & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') + & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end do k = -1, 1 do j = is1_viscous%beg, is1_viscous%end @@ -165,13 +168,13 @@ contains tau_Re(2, 1) = (grad_y_vf(1)%sf(j, k, l) + grad_x_vf(2)%sf(j, k, l))/Re_visc(1) tau_Re(2, 2) = (4._wp*grad_y_vf(2)%sf(j, k, l) - 2._wp*grad_x_vf(1)%sf(j, k, & - & l) - 2._wp*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/(3._wp*Re_visc(1)) + & l) - 2._wp*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/(3._wp*Re_visc(1)) $:GPU_LOOP(parallelism='[seq]') do i = 1, 2 tau_Re_vf(contxe + i)%sf(j, k, l) = tau_Re_vf(contxe + i)%sf(j, k, l) - tau_Re(2, i) tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(contxe + i)%sf(j, k, & - & l)*tau_Re(2, i) + & l)*tau_Re(2, i) end do end do end do @@ -183,7 +186,7 @@ contains #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 if (bulk_stress) then ! Bulk stresses $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & - & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') + & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end do k = -1, 1 do j = is1_viscous%beg, is1_viscous%end @@ -263,12 +266,12 @@ contains end if tau_Re(2, 2) = (grad_x_vf(1)%sf(j, k, l) + grad_y_vf(2)%sf(j, k, l) + q_prim_vf(momxb + 1)%sf(j, k, & - & l)/y_cc(k))/Re_visc(2) + & l)/y_cc(k))/Re_visc(2) tau_Re_vf(momxb + 1)%sf(j, k, l) = tau_Re_vf(momxb + 1)%sf(j, k, l) - tau_Re(2, 2) tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(momxb + 1)%sf(j, k, & - & l)*tau_Re(2, 2) + & l)*tau_Re(2, 2) end do end do end do @@ -280,7 +283,7 @@ contains #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 if (shear_stress) then ! Shear stresses $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & - & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') + & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end do k = -1, 1 do j = is1_viscous%beg, is1_viscous%end @@ -362,14 +365,14 @@ contains tau_Re(2, 2) = -(2._wp/3._wp)*grad_z_vf(3)%sf(j, k, l)/y_cc(k)/Re_visc(1) tau_Re(2, 3) = ((grad_z_vf(2)%sf(j, k, l) - q_prim_vf(momxe)%sf(j, k, & - & l))/y_cc(k) + grad_y_vf(3)%sf(j, k, l))/Re_visc(1) + & l))/y_cc(k) + grad_y_vf(3)%sf(j, k, l))/Re_visc(1) $:GPU_LOOP(parallelism='[seq]') do i = 2, 3 tau_Re_vf(contxe + i)%sf(j, k, l) = tau_Re_vf(contxe + i)%sf(j, k, l) - tau_Re(2, i) tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(contxe + i)%sf(j, k, & - & l)*tau_Re(2, i) + & l)*tau_Re(2, i) end do end do end do @@ -379,7 +382,7 @@ contains if (bulk_stress) then ! Bulk stresses $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & - & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') + & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end do k = -1, 1 do j = is1_viscous%beg, is1_viscous%end @@ -463,13 +466,14 @@ contains tau_Re_vf(momxb + 1)%sf(j, k, l) = tau_Re_vf(momxb + 1)%sf(j, k, l) - tau_Re(2, 2) tau_Re_vf(E_idx)%sf(j, k, l) = tau_Re_vf(E_idx)%sf(j, k, l) - q_prim_vf(momxb + 1)%sf(j, k, & - & l)*tau_Re(2, 2) + & l)*tau_Re(2, 2) end do end do end do $:END_GPU_PARALLEL_LOOP() end if #:endif + end subroutine s_compute_viscous_stress_cylindrical_boundary !> Computes viscous terms @@ -495,16 +499,17 @@ contains !! @param iy Index bounds in the y-direction !! @param iz Index bounds in the z-direction subroutine s_get_viscous(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, & + & qL_prim, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, & - & q_prim_qp, dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, ix, iy, iz) + & q_prim_qp, dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, 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, qL_prim_rsy_vf, qR_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsz_vf + & qR_prim_rsx_vf, qL_prim_rsy_vf, qR_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsz_vf type(vector_field), dimension(num_dims), intent(inout) :: qL_prim, qR_prim type(vector_field), intent(in) :: q_prim_qp type(vector_field), dimension(1:num_dims), intent(inout) :: dqL_prim_dx_n, dqR_prim_dx_n, dqL_prim_dy_n, dqR_prim_dy_n, & - & dqL_prim_dz_n, dqR_prim_dz_n + & dqL_prim_dz_n, dqR_prim_dz_n type(vector_field), dimension(1), intent(inout) :: dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp type(int_bounds_info), intent(in) :: ix, iy, iz @@ -516,23 +521,25 @@ contains $:GPU_UPDATE(device='[iv]') call s_reconstruct_cell_boundary_values_visc(q_prim_qp%vf(iv%beg:iv%end), qL_prim_rsx_vf, qL_prim_rsy_vf, & - & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, i, qL_prim(i)%vf(iv%beg:iv%end), & - & qR_prim(i)%vf(iv%beg:iv%end), ix, iy, iz) + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, i, & + & qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), ix, iy, iz) end do if (weno_Re_flux) then - ! Compute velocity gradient at cell centers using scalar - ! divergence theorem + ! Compute velocity gradient at cell centers using scalar divergence theorem do i = 1, num_dims if (i == 1) then call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & - & dq_prim_dx_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dx, m, buff_size) + & dq_prim_dx_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dx, m, & + & buff_size) else if (i == 2) then call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & - & dq_prim_dy_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dy, n, buff_size) + & dq_prim_dy_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dy, n, & + & buff_size) else call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & - & dq_prim_dz_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dz, p, buff_size) + & dq_prim_dz_qp(1)%vf(iv%beg:iv%end), i, ix, iy, iz, iv, dz, p, & + & buff_size) end if end do else ! Compute velocity gradient at cell centers using finite differences @@ -551,7 +558,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dx_n(1)%vf(i)%sf(j, k, l) = (q_prim_qp%vf(i)%sf(j, k, l) - q_prim_qp%vf(i)%sf(j - 1, k, & - & l))/(x_cc(j) - x_cc(j - 1)) + & l))/(x_cc(j) - x_cc(j - 1)) end do end do end do @@ -565,7 +572,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dx_n(1)%vf(i)%sf(j, k, l) = (q_prim_qp%vf(i)%sf(j + 1, k, l) - q_prim_qp%vf(i)%sf(j, k, & - & l))/(x_cc(j + 1) - x_cc(j)) + & l))/(x_cc(j + 1) - x_cc(j)) end do end do end do @@ -581,7 +588,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dy_n(2)%vf(i)%sf(k, j, l) = (q_prim_qp%vf(i)%sf(k, j, l) - q_prim_qp%vf(i)%sf(k, & - & j - 1, l))/(y_cc(j) - y_cc(j - 1)) + & j - 1, l))/(y_cc(j) - y_cc(j - 1)) end do end do end do @@ -595,7 +602,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dy_n(2)%vf(i)%sf(k, j, l) = (q_prim_qp%vf(i)%sf(k, j + 1, l) - q_prim_qp%vf(i)%sf(k, & - & j, l))/(y_cc(j + 1) - y_cc(j)) + & j, l))/(y_cc(j + 1) - y_cc(j)) end do end do end do @@ -609,8 +616,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dx_n(1)%vf(i)%sf(k, j, & - & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j - 1, & - & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j - 1, l)) + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j - 1, & + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j - 1, l)) dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqL_prim_dx_n(2)%vf(i)%sf(k, j, l) end do @@ -626,8 +633,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dx_n(1)%vf(i)%sf(k, j + 1, & - & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j, & - & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l)) + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j + 1, l) + dqL_prim_dx_n(1)%vf(i)%sf(k, j, & + & l) + dqR_prim_dx_n(1)%vf(i)%sf(k, j, l)) dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqR_prim_dx_n(2)%vf(i)%sf(k, j, l) end do @@ -643,8 +650,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dy_n(2)%vf(i)%sf(j, k, & - & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j - 1, k, & - & l) + dqR_prim_dy_n(2)%vf(i)%sf(j - 1, k, l)) + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j - 1, k, & + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j - 1, k, l)) dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqL_prim_dy_n(1)%vf(i)%sf(j, k, l) end do @@ -660,8 +667,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dy_n(2)%vf(i)%sf(j + 1, k, & - & l) + dqR_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j, k, & - & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l)) + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j + 1, k, l) + dqL_prim_dy_n(2)%vf(i)%sf(j, k, & + & l) + dqR_prim_dy_n(2)%vf(i)%sf(j, k, l)) dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqR_prim_dy_n(1)%vf(i)%sf(j, k, l) end do @@ -680,7 +687,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dz_n(3)%vf(i)%sf(k, l, j) = (q_prim_qp%vf(i)%sf(k, l, j) - q_prim_qp%vf(i)%sf(k, & - & l, j - 1))/(z_cc(j) - z_cc(j - 1)) + & l, j - 1))/(z_cc(j) - z_cc(j - 1)) end do end do end do @@ -694,7 +701,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dz_n(3)%vf(i)%sf(k, l, j) = (q_prim_qp%vf(i)%sf(k, l, & - & j + 1) - q_prim_qp%vf(i)%sf(k, l, j))/(z_cc(j + 1) - z_cc(j)) + & j + 1) - q_prim_qp%vf(i)%sf(k, l, j))/(z_cc(j + 1) - z_cc(j)) end do end do end do @@ -708,8 +715,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dz_n(3)%vf(i)%sf(j, k, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, l) + dqL_prim_dz_n(3)%vf(i)%sf(j - 1, k, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(j - 1, k, l)) + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, & + & l) + dqL_prim_dz_n(3)%vf(i)%sf(j - 1, k, & + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j - 1, k, l)) dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqL_prim_dz_n(1)%vf(i)%sf(j, k, l) end do @@ -725,8 +733,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = (dqL_prim_dz_n(3)%vf(i)%sf(j + 1, k, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(j + 1, k, l) + dqL_prim_dz_n(3)%vf(i)%sf(j, k, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, l)) + & l) + dqR_prim_dz_n(3)%vf(i)%sf(j + 1, k, & + & l) + dqL_prim_dz_n(3)%vf(i)%sf(j, k, l) + dqR_prim_dz_n(3)%vf(i)%sf(j, k, & + & l)) dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) = 25.e-2_wp*dqR_prim_dz_n(1)%vf(i)%sf(j, k, l) end do @@ -742,8 +751,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dz_n(3)%vf(i)%sf(k, j, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l) + dqL_prim_dz_n(3)%vf(i)%sf(k, j - 1, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j - 1, l)) + & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l) + dqL_prim_dz_n(3)%vf(i)%sf(k, & + & j - 1, l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j - 1, l)) dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqL_prim_dz_n(2)%vf(i)%sf(k, j, l) end do @@ -759,8 +768,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = (dqL_prim_dz_n(3)%vf(i)%sf(k, j + 1, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j + 1, l) + dqL_prim_dz_n(3)%vf(i)%sf(k, j, & - & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, l)) + & l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j + 1, & + & l) + dqL_prim_dz_n(3)%vf(i)%sf(k, j, l) + dqR_prim_dz_n(3)%vf(i)%sf(k, j, & + & l)) dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) = 25.e-2_wp*dqR_prim_dz_n(2)%vf(i)%sf(k, j, l) end do @@ -776,8 +786,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dy_n(2)%vf(i)%sf(k, l, & - & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & - & j - 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j - 1)) + & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & + & j - 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j - 1)) dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqL_prim_dy_n(3)%vf(i)%sf(k, l, j) end do @@ -793,8 +803,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dy_n(2)%vf(i)%sf(k, l, & - & j + 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j + 1) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & - & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j)) + & j + 1) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, & + & j + 1) + dqL_prim_dy_n(2)%vf(i)%sf(k, l, & + & j) + dqR_prim_dy_n(2)%vf(i)%sf(k, l, j)) dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqR_prim_dy_n(3)%vf(i)%sf(k, l, j) end do @@ -809,8 +820,8 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dx_n(1)%vf(i)%sf(k, l, & - & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & - & j - 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j - 1)) + & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & + & j - 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j - 1)) dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqL_prim_dx_n(3)%vf(i)%sf(k, l, j) end do @@ -825,8 +836,9 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = (dqL_prim_dx_n(1)%vf(i)%sf(k, l, & - & j + 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j + 1) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & - & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j)) + & j + 1) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, & + & j + 1) + dqL_prim_dx_n(1)%vf(i)%sf(k, l, & + & j) + dqR_prim_dx_n(1)%vf(i)%sf(k, l, j)) dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) = 25.e-2_wp*dqR_prim_dx_n(3)%vf(i)%sf(k, l, j) end do @@ -837,40 +849,43 @@ contains do i = iv%beg, iv%end call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dy_qp(1)%vf(i), & - & dq_prim_dz_qp(1)%vf(i)) + & dq_prim_dz_qp(1)%vf(i)) end do #:endif else do i = iv%beg, iv%end call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dy_qp(1)%vf(i), & - & dq_prim_dy_qp(1)%vf(i)) + & dq_prim_dy_qp(1)%vf(i)) end do end if else do i = iv%beg, iv%end call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dx_qp(1)%vf(i), & - & dq_prim_dx_qp(1)%vf(i)) + & dq_prim_dx_qp(1)%vf(i)) end do end if end if + end subroutine s_get_viscous !> @brief Reconstructs left and right cell-boundary values of viscous primitive variables using WENO or MUSCL. subroutine s_reconstruct_cell_boundary_values_visc(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & + & vR_prim_vf, ix, iy, iz) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & - & vR_y, vR_z + & vR_y, vR_z integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz integer :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] + if (recon_type == ${TYPE}$ .or. dummy) then ! Reconstruction in s1-direction @@ -892,16 +907,17 @@ contains if (n > 0) then if (p > 0) then call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:, & - & iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & + & :, iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, & - & is1_viscous, is2_viscous, is3_viscous) + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & + & recon_dir, is1_viscous, is2_viscous, is3_viscous) end if else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & - & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, is3_viscous) + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & + & is3_viscous) end if end if #:endfor @@ -950,20 +966,23 @@ contains end if end if end if + end subroutine s_reconstruct_cell_boundary_values_visc !> @brief Reconstructs left and right cell-boundary values of viscous primitive variable derivatives using WENO or MUSCL. subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & + & vR_prim_vf, ix, iy, iz) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & - & vR_y, vR_z + & vR_y, vR_z type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf type(int_bounds_info), intent(in) :: ix, iy, iz integer, intent(in) :: norm_dir integer :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] + if (recon_type == ${TYPE}$) then ! Reconstruction in s1-direction @@ -984,17 +1003,18 @@ contains if (n > 0) then if (p > 0) then call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:, & - & iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) + & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & + & :, iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, & - & is1_viscous, is2_viscous, is3_viscous) + & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & + & recon_dir, is1_viscous, is2_viscous, is3_viscous) end if else call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & - & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, is3_viscous) + & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & + & is3_viscous) end if end if #:endfor @@ -1043,6 +1063,7 @@ contains end if end if end if + end subroutine s_reconstruct_cell_boundary_values_visc_deriv !> The purpose of this subroutine is to employ the inputted left and right cell-boundary integral-averaged variables to compute @@ -1060,6 +1081,7 @@ contains !! @param dim Dimension size !! @param buff_size_in Buffer layer size subroutine s_apply_scalar_divergence_theorem(vL_vf, vR_vf, dv_ds_vf, norm_dir, ix, iy, iz, iv_in, dL, dim, buff_size_in) + ! arrays of cell widths type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: vL_vf, vR_vf type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: dv_ds_vf @@ -1068,6 +1090,7 @@ contains integer, intent(in) :: dim, buff_size_in real(wp), dimension(-buff_size_in:dim + buff_size_in), intent(in) :: dL integer :: i, j, k, l !< Generic loop iterators + is1_viscous = ix is2_viscous = iy is3_viscous = iz @@ -1077,11 +1100,9 @@ contains ! First-Order Spatial Derivatives in x-direction if (norm_dir == 1) then - ! A general application of the scalar divergence theorem that - ! utilizes the left and right cell-boundary integral-averages, - ! inside each cell, or an arithmetic mean of these two at the - ! cell-boundaries, to calculate the cell-averaged first-order - ! spatial derivatives inside the cell. + ! A general application of the scalar divergence theorem that utilizes the left and right cell-boundary + ! integral-averages, inside each cell, or an arithmetic mean of these two at the cell-boundaries, to calculate the + ! cell-averaged first-order spatial derivatives inside the cell. $:GPU_PARALLEL_LOOP(collapse=3) do l = is3_viscous%beg, is3_viscous%end @@ -1090,7 +1111,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(j))*(wa_flg*vL_vf(i)%sf(j + 1, k, & - & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j - 1, k, l)) + & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j - 1, k, l)) end do end do end do @@ -1101,11 +1122,9 @@ contains ! First-Order Spatial Derivatives in y-direction else if (norm_dir == 2) then - ! A general application of the scalar divergence theorem that - ! utilizes the left and right cell-boundary integral-averages, - ! inside each cell, or an arithmetic mean of these two at the - ! cell-boundaries, to calculate the cell-averaged first-order - ! spatial derivatives inside the cell. + ! A general application of the scalar divergence theorem that utilizes the left and right cell-boundary + ! integral-averages, inside each cell, or an arithmetic mean of these two at the cell-boundaries, to calculate the + ! cell-averaged first-order spatial derivatives inside the cell. $:GPU_PARALLEL_LOOP(collapse=3) do l = is3_viscous%beg, is3_viscous%end @@ -1114,7 +1133,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(k))*(wa_flg*vL_vf(i)%sf(j, k + 1, & - & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k - 1, l)) + & l) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k - 1, l)) end do end do end do @@ -1126,11 +1145,9 @@ contains ! First-Order Spatial Derivatives in z-direction else - ! A general application of the scalar divergence theorem that - ! utilizes the left and right cell-boundary integral-averages, - ! inside each cell, or an arithmetic mean of these two at the - ! cell-boundaries, to calculate the cell-averaged first-order - ! spatial derivatives inside the cell. + ! A general application of the scalar divergence theorem that utilizes the left and right cell-boundary + ! integral-averages, inside each cell, or an arithmetic mean of these two at the cell-boundaries, to calculate the + ! cell-averaged first-order spatial derivatives inside the cell. $:GPU_PARALLEL_LOOP(collapse=3) do l = is3_viscous%beg + 1, is3_viscous%end - 1 @@ -1139,7 +1156,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = iv%beg, iv%end dv_ds_vf(i)%sf(j, k, l) = 1._wp/((1._wp + wa_flg)*dL(l))*(wa_flg*vL_vf(i)%sf(j, k, & - & l + 1) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k, l - 1)) + & l + 1) + vR_vf(i)%sf(j, k, l) - vL_vf(i)%sf(j, k, l) - wa_flg*vR_vf(i)%sf(j, k, l - 1)) end do end do end do @@ -1147,6 +1164,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if ! END: First-Order Spatial Derivatives in z-direction + end subroutine s_apply_scalar_divergence_theorem !> Computes the scalar gradient fields via finite differences @@ -1155,12 +1173,14 @@ contains !! @param grad_y Second coordinate direction component of the derivative !! @param grad_z Third coordinate direction component of the derivative subroutine s_compute_fd_gradient(var, grad_x, grad_y, grad_z) + type(scalar_field), intent(in) :: var type(scalar_field), intent(inout) :: grad_x type(scalar_field), intent(inout) :: grad_y type(scalar_field), intent(inout) :: grad_z type(int_bounds_info) :: ix, iy, iz integer :: j, k, l !< Generic loop iterators + ix%beg = 1 - buff_size; ix%end = m + buff_size - 1 if (n > 0) then iy%beg = 1 - buff_size; iy%end = n + buff_size - 1 @@ -1216,9 +1236,9 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end grad_x%sf(idwbuff(1)%beg, k, l) = (-3._wp*var%sf(idwbuff(1)%beg, k, l) + 4._wp*var%sf(idwbuff(1)%beg + 1, k, & - & l) - var%sf(idwbuff(1)%beg + 2, k, l))/(x_cc(idwbuff(1)%beg + 2) - x_cc(idwbuff(1)%beg)) + & l) - var%sf(idwbuff(1)%beg + 2, k, l))/(x_cc(idwbuff(1)%beg + 2) - x_cc(idwbuff(1)%beg)) grad_x%sf(idwbuff(1)%end, k, l) = (+3._wp*var%sf(idwbuff(1)%end, k, l) - 4._wp*var%sf(idwbuff(1)%end - 1, k, & - & l) + var%sf(idwbuff(1)%end - 2, k, l))/(x_cc(idwbuff(1)%end) - x_cc(idwbuff(1)%end - 2)) + & l) + var%sf(idwbuff(1)%end - 2, k, l))/(x_cc(idwbuff(1)%end) - x_cc(idwbuff(1)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1227,9 +1247,9 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_y%sf(j, idwbuff(2)%beg, l) = (-3._wp*var%sf(j, idwbuff(2)%beg, l) + 4._wp*var%sf(j, idwbuff(2)%beg + 1, & - & l) - var%sf(j, idwbuff(2)%beg + 2, l))/(y_cc(idwbuff(2)%beg + 2) - y_cc(idwbuff(2)%beg)) + & l) - var%sf(j, idwbuff(2)%beg + 2, l))/(y_cc(idwbuff(2)%beg + 2) - y_cc(idwbuff(2)%beg)) grad_y%sf(j, idwbuff(2)%end, l) = (+3._wp*var%sf(j, idwbuff(2)%end, l) - 4._wp*var%sf(j, idwbuff(2)%end - 1, & - & l) + var%sf(j, idwbuff(2)%end - 2, l))/(y_cc(idwbuff(2)%end) - y_cc(idwbuff(2)%end - 2)) + & l) + var%sf(j, idwbuff(2)%end - 2, l))/(y_cc(idwbuff(2)%end) - y_cc(idwbuff(2)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1238,11 +1258,11 @@ contains do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_z%sf(j, k, idwbuff(3)%beg) = (-3._wp*var%sf(j, k, idwbuff(3)%beg) + 4._wp*var%sf(j, k, & - & idwbuff(3)%beg + 1) - var%sf(j, k, & - & idwbuff(3)%beg + 2))/(z_cc(idwbuff(3)%beg + 2) - z_cc(is3_viscous%beg)) + & idwbuff(3)%beg + 1) - var%sf(j, k, & + & idwbuff(3)%beg + 2))/(z_cc(idwbuff(3)%beg + 2) - z_cc(is3_viscous%beg)) grad_z%sf(j, k, idwbuff(3)%end) = (+3._wp*var%sf(j, k, idwbuff(3)%end) - 4._wp*var%sf(j, k, & - & idwbuff(3)%end - 1) + var%sf(j, k, & - & idwbuff(3)%end - 2))/(z_cc(idwbuff(3)%end) - z_cc(idwbuff(3)%end - 2)) + & idwbuff(3)%end - 1) + var%sf(j, k, & + & idwbuff(3)%end - 2))/(z_cc(idwbuff(3)%end) - z_cc(idwbuff(3)%end - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1263,7 +1283,7 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end grad_x%sf(m, k, l) = (3._wp*var%sf(m, k, l) - 4._wp*var%sf(m - 1, k, l) + var%sf(m - 2, k, & - & l))/(x_cc(m) - x_cc(m - 2)) + & l))/(x_cc(m) - x_cc(m - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1283,7 +1303,7 @@ contains do l = idwbuff(3)%beg, idwbuff(3)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_y%sf(j, n, l) = (3._wp*var%sf(j, n, l) - 4._wp*var%sf(j, n - 1, l) + var%sf(j, n - 2, & - & l))/(y_cc(n) - y_cc(n - 2)) + & l))/(y_cc(n) - y_cc(n - 2)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1294,7 +1314,7 @@ contains do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_z%sf(j, k, 0) = (-3._wp*var%sf(j, k, 0) + 4._wp*var%sf(j, k, 1) - var%sf(j, k, & - & 2))/(z_cc(2) - z_cc(0)) + & 2))/(z_cc(2) - z_cc(0)) end do end do $:END_GPU_PARALLEL_LOOP() @@ -1304,17 +1324,19 @@ contains do k = idwbuff(2)%beg, idwbuff(2)%end do j = idwbuff(1)%beg, idwbuff(1)%end grad_z%sf(j, k, p) = (3._wp*var%sf(j, k, p) - 4._wp*var%sf(j, k, p - 1) + var%sf(j, k, & - & p - 2))/(z_cc(p) - z_cc(p - 2)) + & p - 2))/(z_cc(p) - z_cc(p - 2)) end do end do $:END_GPU_PARALLEL_LOOP() end if end if end if + end subroutine s_compute_fd_gradient !> @brief Computes the viscous stress tensor at a single grid cell using finite-difference velocity gradients. subroutine s_compute_viscous_stress_tensor(viscous_stress_tensor, q_prim_vf, dynamic_viscosity, i, j, k) + $:GPU_ROUTINE(parallelism='[seq]') real(wp), dimension(1:3, 1:3), intent(inout) :: viscous_stress_tensor @@ -1341,12 +1363,12 @@ contains ! compute the velocity gradient tensor do l = 1, num_dims velocity_gradient_tensor(l, 1) = (q_prim_vf(momxb + l - 1)%sf(i + 1, j, k) - q_prim_vf(momxb + l - 1)%sf(i - 1, j, & - & k))/(2._wp*dx(1)) + & k))/(2._wp*dx(1)) velocity_gradient_tensor(l, 2) = (q_prim_vf(momxb + l - 1)%sf(i, j + 1, k) - q_prim_vf(momxb + l - 1)%sf(i, j - 1, & - & k))/(2._wp*dx(2)) + & k))/(2._wp*dx(2)) if (num_dims == 3) then velocity_gradient_tensor(l, 3) = (q_prim_vf(momxb + l - 1)%sf(i, j, k + 1) - q_prim_vf(momxb + l - 1)%sf(i, j, & - & k - 1))/(2._wp*dx(3)) + & k - 1))/(2._wp*dx(3)) end if end do @@ -1374,10 +1396,14 @@ contains viscous_stress_tensor(l, 3) = 0._wp end do end if + end subroutine s_compute_viscous_stress_tensor !> @brief Deallocates the viscous Reynolds number arrays. impure subroutine s_finalize_viscous_module() + @:DEALLOCATE(Res_viscous) + end subroutine s_finalize_viscous_module + end module m_viscous diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index b19dee2fc1..71d13e305b 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -6,8 +6,9 @@ !> @brief WENO/WENO-Z/TENO reconstruction with optional monotonicity-preserving bounds and mapped weights module m_weno - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + + use m_derived_types !< Definitions of the derived types + use m_global_parameters !< Definitions of the global parameters use m_variables_conversion !< State variables type conversion procedures ! $:USE_GPU_MODULE() @@ -78,11 +79,13 @@ module m_weno #endif ! !> @} + contains !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are necessary to setup the module. impure subroutine s_initialize_weno_module + if (weno_order == 1) return ! Allocating/Computing WENO Coefficients in x-direction @@ -110,9 +113,9 @@ contains @:ALLOCATE(d_cbR_x(0:weno_num_stencils, is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn)) @:ALLOCATE(beta_coef_x(is1_weno%beg + weno_polyn:is1_weno%end - weno_polyn, 0:weno_polyn, & - & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) - ! Number of cross terms for dvd = (k-1)(k-1+1)/2, where weno_polyn = k-1 - ! Note: k-1 not k because we are using value differences (dvd) not the values themselves + & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + ! Number of cross terms for dvd = (k-1)(k-1+1)/2, where weno_polyn = k-1 Note: k-1 not k because we are using value + ! differences (dvd) not the values themselves call s_compute_weno_coefficients(1, is1_weno) @@ -139,7 +142,7 @@ contains @:ALLOCATE(d_cbR_y(0:weno_num_stencils, is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn)) @:ALLOCATE(beta_coef_y(is2_weno%beg + weno_polyn:is2_weno%end - weno_polyn, 0:weno_polyn, & - & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) call s_compute_weno_coefficients(2, is2_weno) @@ -159,18 +162,20 @@ contains @:ALLOCATE(d_cbR_z(0:weno_num_stencils, is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn)) @:ALLOCATE(beta_coef_z(is3_weno%beg + weno_polyn:is3_weno%end - weno_polyn, 0:weno_polyn, & - & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) + & 0:weno_polyn*(weno_polyn + 1)/2 - 1)) call s_compute_weno_coefficients(3, is3_weno) @:ALLOCATE(v_rs_ws_z(is3_weno%beg:is3_weno%end, is2_weno%beg:is2_weno%end, is1_weno%beg:is1_weno%end, 1:sys_size)) + end subroutine s_initialize_weno_module !> The purpose of this subroutine is to compute the grid dependent coefficients of the WENO polynomials, ideal weights and !! smoothness indicators, provided the order, the coordinate direction and the location of the WENO reconstruction. - !! @param weno_dir Coordinate direction of the WENO reconstruction - !! @param is Index bounds in the s-direction + !! @param weno_dir Coordinate direction of the WENO reconstruction + !! @param is Index bounds in the s-direction subroutine s_compute_weno_coefficients(weno_dir, is) + integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is integer :: s @@ -180,9 +185,9 @@ contains real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil - ! Determining the number of cells, the cell-boundary locations and - ! the boundary conditions in the coordinate direction selected for - ! the WENO reconstruction + ! Determining the number of cells, the cell-boundary locations and the boundary conditions in the coordinate direction + ! selected for the WENO reconstruction + if (weno_dir == 1) then s = m; s_cb => x_cb; bc_s = bc_x else if (weno_dir == 2) then @@ -212,10 +217,8 @@ contains beta_coef_${XYZ}$ (i + 1, 1, 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp/(s_cb(i - 1) - s_cb(i + 1))**2._wp end do - ! Modifying the ideal weights coefficients in the neighborhood - ! of beginning and end Riemann state extrapolation BC to avoid - ! any contributions from outside of the physical domain during - ! the WENO reconstruction + ! Modifying the ideal weights coefficients in the neighborhood of beginning and end Riemann state extrapolation + ! BC to avoid any contributions from outside of the physical domain during the WENO reconstruction if (null_weights) then if (bc_s%beg == BC_RIEMANN_EXTRAP) then d_cbR_${XYZ}$ (1, 0) = 0._wp; d_cbR_${XYZ}$ (0, 0) = 1._wp @@ -233,113 +236,112 @@ contains else if (weno_order == 5) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 0) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i) - s_cb(i + 3))*(s_cb(i + 3) & - & - s_cb(i + 1))) + & 0) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i) - s_cb(i & + & + 3))*(s_cb(i + 3) - s_cb(i + 1))) poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 0) = ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) - s_cb(i + 2))*(s_cb(i + 2) & - & - s_cb(i))) + & 0) = ((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) & + & - s_cb(i + 2))*(s_cb(i + 2) - s_cb(i))) poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i - 1) & - & - s_cb(i + 2))) + & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i - 1) & + & - s_cb(i + 1))*(s_cb(i - 1) - s_cb(i + 2))) poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i))*(s_cb(i - 2) & - & - s_cb(i + 1))) + & 1) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) & + & - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))) poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 0) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i) - s_cb(i + 3))*(s_cb(i + 3) & - & - s_cb(i + 1))) + & 0) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i) - s_cb(i + 3)) & + & *(s_cb(i + 3) - s_cb(i + 1))) poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 0) = ((s_cb(i) - s_cb(i - 1))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 1) - s_cb(i + 2))*(s_cb(i) & - & - s_cb(i + 2))) + & 0) = ((s_cb(i) - s_cb(i - 1))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 1) - s_cb(i & + & + 2))*(s_cb(i) - s_cb(i + 2))) poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 1) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i - 1) - s_cb(i + 1))*(s_cb(i - 1) & - & - s_cb(i + 2))) + & 1) = ((s_cb(i + 1) - s_cb(i))*(s_cb(i) - s_cb(i + 2)))/((s_cb(i - 1) - s_cb(i & + & + 1))*(s_cb(i - 1) - s_cb(i + 2))) poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 1) = ((s_cb(i - 1) - s_cb(i))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 2) - s_cb(i))*(s_cb(i - 2) & - & - s_cb(i + 1))) + & 1) = ((s_cb(i - 1) - s_cb(i))*(s_cb(i) - s_cb(i + 1)))/((s_cb(i - 2) - s_cb(i)) & + & *(s_cb(i - 2) - s_cb(i + 1))) poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i) - s_cb(i + 2))*(s_cb(i) & - & - s_cb(i + 3)))*((s_cb(i) - s_cb(i + 1))) + & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i) - s_cb(i & + & + 2))*(s_cb(i) - s_cb(i + 3)))*((s_cb(i) - s_cb(i + 1))) poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 0) = ((s_cb(i - 2) - s_cb(i + 1)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 1) - s_cb(i + 1)) & - & *(s_cb(i + 1) - s_cb(i - 2)))*((s_cb(i + 1) - s_cb(i))) + & 0) = ((s_cb(i - 2) - s_cb(i + 1)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 1) & + & - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 2)))*((s_cb(i + 1) - s_cb(i))) poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i) - s_cb(i + 3)))/((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i & - & + 3)))*((s_cb(i + 1) - s_cb(i))) + & 1) = ((s_cb(i) - s_cb(i + 2)) + (s_cb(i) - s_cb(i + 3)))/((s_cb(i) - s_cb(i + 2)) & + & *(s_cb(i) - s_cb(i + 3)))*((s_cb(i + 1) - s_cb(i))) poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 0) = ((s_cb(i - 2) - s_cb(i)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i & - & + 1) - s_cb(i - 1)))*((s_cb(i) - s_cb(i + 1))) + & 0) = ((s_cb(i - 2) - s_cb(i)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 2) & + & - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))*((s_cb(i) - s_cb(i + 1))) d_cbR_${XYZ}$ (0, & - & i + 1) = ((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i + 3)) & - & *(s_cb(i + 3) - s_cb(i - 1))) + & i + 1) = ((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) & + & - s_cb(i + 3))*(s_cb(i + 3) - s_cb(i - 1))) d_cbR_${XYZ}$ (2, & - & i + 1) = ((s_cb(i + 1) - s_cb(i + 2))*(s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i - 2) - s_cb(i + 2)) & - & *(s_cb(i - 2) - s_cb(i + 3))) + & i + 1) = ((s_cb(i + 1) - s_cb(i + 2))*(s_cb(i + 1) - s_cb(i + 3)))/((s_cb(i - 2) & + & - s_cb(i + 2))*(s_cb(i - 2) - s_cb(i + 3))) d_cbL_${XYZ}$ (0, & - & i + 1) = ((s_cb(i - 2) - s_cb(i))*(s_cb(i) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i + 3))*(s_cb(i + 3) & - & - s_cb(i - 1))) + & i + 1) = ((s_cb(i - 2) - s_cb(i))*(s_cb(i) - s_cb(i - 1)))/((s_cb(i - 2) - s_cb(i + 3)) & + & *(s_cb(i + 3) - s_cb(i - 1))) d_cbL_${XYZ}$ (2, & - & i + 1) = ((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3)))/((s_cb(i - 2) - s_cb(i + 2))*(s_cb(i - 2) & - & - s_cb(i + 3))) + & i + 1) = ((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3)))/((s_cb(i - 2) - s_cb(i + 2)) & + & *(s_cb(i - 2) - s_cb(i + 3))) d_cbR_${XYZ}$ (1, i + 1) = 1._wp - d_cbR_${XYZ}$ (0, i + 1) - d_cbR_${XYZ}$ (2, i + 1) d_cbL_${XYZ}$ (1, i + 1) = 1._wp - d_cbL_${XYZ}$ (0, i + 1) - d_cbL_${XYZ}$ (2, i + 1) beta_coef_${XYZ}$ (i + 1, 0, & - & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i + 1) & - & - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2._wp)/((s_cb(i) - s_cb(i + 3) & - & )**2._wp*(s_cb(i + 1) - s_cb(i + 3))**2._wp) + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1)) & + & **2._wp)/((s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 1) - s_cb(i + 3))**2._wp) beta_coef_${XYZ}$ (i + 1, 0, & - & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp - (s_cb(i + 1) & - & - s_cb(i))*(s_cb(i + 3) - s_cb(i + 1)) + 2._wp*(s_cb(i + 2) - s_cb(i))*((s_cb(i + 2) - s_cb(i)) & - & + (s_cb(i + 3) - s_cb(i + 1))))/((s_cb(i) - s_cb(i + 2))*(s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 3) & - & - s_cb(i + 1))) + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & - (s_cb(i + 1) - s_cb(i))*(s_cb(i + 3) - s_cb(i + 1)) + 2._wp*(s_cb(i + 2) - s_cb(i)) & + & *((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))))/((s_cb(i) - s_cb(i + 2)) & + & *(s_cb(i) - s_cb(i + 3))**2._wp*(s_cb(i + 3) - s_cb(i + 1))) beta_coef_${XYZ}$ (i + 1, 0, & - & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i + 1) & - & - s_cb(i))*((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))) + ((s_cb(i + 2) - s_cb(i)) & - & + (s_cb(i + 3) - s_cb(i + 1)))**2._wp)/((s_cb(i) - s_cb(i + 2))**2._wp*(s_cb(i) - s_cb(i + 3))**2._wp) + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i + 1) - s_cb(i))*((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1))) & + & + ((s_cb(i + 2) - s_cb(i)) + (s_cb(i + 3) - s_cb(i + 1)))**2._wp)/((s_cb(i) - s_cb(i & + & + 2))**2._wp*(s_cb(i) - s_cb(i + 3))**2._wp) beta_coef_${XYZ}$ (i + 1, 1, & - & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i) & - & - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 1) - s_cb(i + 2) & - & )**2._wp*(s_cb(i) - s_cb(i + 2))**2._wp) + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i) - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i))) & + & /((s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i) - s_cb(i + 2))**2._wp) beta_coef_${XYZ}$ (i + 1, 1, & - & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*((s_cb(i) - s_cb(i + 1))*((s_cb(i) - s_cb(i - 1)) & - & + 20._wp*(s_cb(i + 1) - s_cb(i))) + (2._wp*(s_cb(i) - s_cb(i - 1)) + (s_cb(i + 1) - s_cb(i))) & - & *(s_cb(i + 2) - s_cb(i)))/((s_cb(i + 1) - s_cb(i - 1))*(s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i & - & + 2) - s_cb(i))) + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*((s_cb(i) - s_cb(i + 1))*((s_cb(i) & + & - s_cb(i - 1)) + 20._wp*(s_cb(i + 1) - s_cb(i))) + (2._wp*(s_cb(i) - s_cb(i - 1)) & + & + (s_cb(i + 1) - s_cb(i)))*(s_cb(i + 2) - s_cb(i)))/((s_cb(i + 1) - s_cb(i - 1)) & + & *(s_cb(i - 1) - s_cb(i + 2))**2._wp*(s_cb(i + 2) - s_cb(i))) beta_coef_${XYZ}$ (i + 1, 1, & - & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i + 1) & - & - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1))**2._wp)/((s_cb(i - 1) - s_cb(i & - & + 1))**2._wp*(s_cb(i - 1) - s_cb(i + 2))**2._wp) + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1)) & + & **2._wp)/((s_cb(i - 1) - s_cb(i + 1))**2._wp*(s_cb(i - 1) - s_cb(i + 2))**2._wp) beta_coef_${XYZ}$ (i + 1, 2, & - & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(12._wp*(s_cb(i + 1) - s_cb(i))**2._wp + ((s_cb(i) & - & - s_cb(i - 2)) + (s_cb(i) - s_cb(i - 1)))**2._wp + 3._wp*((s_cb(i) - s_cb(i - 2)) + (s_cb(i) & - & - s_cb(i - 1)))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i - 1) - s_cb(i & - & + 1))**2._wp) + & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(12._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + ((s_cb(i) - s_cb(i - 2)) + (s_cb(i) - s_cb(i - 1)))**2._wp + 3._wp*((s_cb(i) & + & - s_cb(i - 2)) + (s_cb(i) - s_cb(i - 1)))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) & + & - s_cb(i + 1))**2._wp*(s_cb(i - 1) - s_cb(i + 1))**2._wp) beta_coef_${XYZ}$ (i + 1, 2, & - & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp + ((s_cb(i) & - & - s_cb(i - 2))*(s_cb(i) - s_cb(i + 1))) + 2._wp*(s_cb(i + 1) - s_cb(i - 1))*((s_cb(i) - s_cb(i - 2)) & - & + (s_cb(i + 1) - s_cb(i - 1))))/((s_cb(i - 2) - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i & - & + 1) - s_cb(i - 1))) + & 1) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(19._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + ((s_cb(i) - s_cb(i - 2))*(s_cb(i) - s_cb(i + 1))) + 2._wp*(s_cb(i + 1) - s_cb(i & + & - 1))*((s_cb(i) - s_cb(i - 2)) + (s_cb(i + 1) - s_cb(i - 1))))/((s_cb(i - 2) & + & - s_cb(i))*(s_cb(i - 2) - s_cb(i + 1))**2._wp*(s_cb(i + 1) - s_cb(i - 1))) beta_coef_${XYZ}$ (i + 1, 2, & - & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp + (s_cb(i) & - & - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i)))/((s_cb(i - 2) - s_cb(i)) & - & **2._wp*(s_cb(i - 2) - s_cb(i + 1))**2._wp) + & 2) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & + & + (s_cb(i) - s_cb(i - 1))**2._wp + (s_cb(i) - s_cb(i - 1))*(s_cb(i + 1) - s_cb(i))) & + & /((s_cb(i - 2) - s_cb(i))**2._wp*(s_cb(i - 2) - s_cb(i + 1))**2._wp) end do - ! Modifying the ideal weights coefficients in the neighborhood - ! of beginning and end Riemann state extrapolation BC to avoid - ! any contributions from outside of the physical domain during - ! the WENO reconstruction + ! Modifying the ideal weights coefficients in the neighborhood of beginning and end Riemann state extrapolation + ! BC to avoid any contributions from outside of the physical domain during the WENO reconstruction if (null_weights) then if (bc_s%beg == BC_RIEMANN_EXTRAP) then d_cbR_${XYZ}$ (1:2, 0) = 0._wp; d_cbR_${XYZ}$ (0, 0) = 1._wp @@ -350,9 +352,9 @@ contains if (bc_s%end == BC_RIEMANN_EXTRAP) then d_cbR_${XYZ}$ (0, s - 1) = 0._wp; d_cbR_${XYZ}$ (:, s - 1) = d_cbR_${XYZ}$ (:, & - & s - 1)/sum(d_cbR_${XYZ}$ (:, s - 1)) + & s - 1)/sum(d_cbR_${XYZ}$ (:, s - 1)) d_cbL_${XYZ}$ (0, s - 1) = 0._wp; d_cbL_${XYZ}$ (:, s - 1) = d_cbL_${XYZ}$ (:, & - & s - 1)/sum(d_cbL_${XYZ}$ (:, s - 1)) + & s - 1)/sum(d_cbL_${XYZ}$ (:, s - 1)) d_cbR_${XYZ}$ (0:1, s) = 0._wp; d_cbR_${XYZ}$ (2, s) = 1._wp d_cbL_${XYZ}$ (0:1, s) = 0._wp; d_cbL_${XYZ}$ (2, s) = 1._wp end if @@ -362,413 +364,463 @@ contains if (.not. teno) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn ! Reference: Shu (1997) "Essentially Non-Oscillatory and Weighted Essentially Non-Oscillatory Schemes - ! for Hyperbolic Conservation Laws" - ! Equation 2.20: Polynomial Coefficients (poly_coef_cb) - ! Equation 2.61: Smoothness Indicators (beta_coef) - ! To reduce computational cost, we leverage the fact that all polynomial coefficients in a stencil sum - ! to 1 - ! and compute the polynomial coefficients (poly_coef_cb) for the cell value differences (dvd) instead of - ! the values themselves. - ! The computation of coefficients is further simplified by using grid spacing (y or w) rather than the - ! grid locations (s_cb) directly. + ! for Hyperbolic Conservation Laws" Equation 2.20: Polynomial Coefficients (poly_coef_cb) Equation 2.61: + ! Smoothness Indicators (beta_coef) To reduce computational cost, we leverage the fact that all + ! polynomial coefficients in a stencil sum to 1 and compute the polynomial coefficients (poly_coef_cb) + ! for the cell value differences (dvd) instead of the values themselves. The computation of coefficients + ! is further simplified by using grid spacing (y or w) rather than the grid locations (s_cb) directly. ! Ideal weights (d_cb) are obtained by comparing the grid location coefficients of the polynomial - ! coefficients. - ! The smoothness indicators (beta_coef) are calculated through numerical differentiation and integration - ! of each cross term of the polynomial coefficients, - ! using the cell value differences (dvd) instead of the values themselves. - ! While the polynomial coefficients sum to 1, the derivative of 1 is 0, which means it does not create - ! additional cross terms in the smoothness indicators. + ! coefficients. The smoothness indicators (beta_coef) are calculated through numerical differentiation + ! and integration of each cross term of the polynomial coefficients, using the cell value differences + ! (dvd) instead of the values themselves. While the polynomial coefficients sum to 1, the derivative of + ! 1 is 0, which means it does not create additional cross terms in the smoothness indicators. w = s_cb(i - 3:i + 4) - s_cb(i) ! Offset using s_cb(i) to reduce floating point error d_cbR_${XYZ}$ (0, & - & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))) & - & !& + & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & + & *(w(1) - w(8))) !& d_cbR_${XYZ}$ (1, & - & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1)*w(7) - w(2) & - & *w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7)*w(8) + w(1)**2 + w(2) & - & **2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1) & + & *w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7) & + & *w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7)) & + & *(w(2) - w(8))) !& d_cbR_${XYZ}$ (2, & - & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2)*w(3) - w(1) & - & *w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7)*w(8) + w(7)**2 + w(8) & - & **2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))*(w(3) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2) & + & *w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7) & + & *w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8)) & + & *(w(3) - w(8))) !& d_cbR_${XYZ}$ (3, & - & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8))*(w(3) - w(8))) & - & !& + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8)) & + & *(w(3) - w(8))) !& w = s_cb(i + 4:i - 3:-1) - s_cb(i) d_cbL_${XYZ}$ (0, & - & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8))*(w(3) - w(8))) & - & !& + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8)) & + & *(w(3) - w(8))) !& d_cbL_${XYZ}$ (1, & - & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2)*w(3) - w(1) & - & *w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7)*w(8) + w(7)**2 + w(8) & - & **2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))*(w(3) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2) & + & *w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7) & + & *w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8)) & + & *(w(3) - w(8))) !& d_cbL_${XYZ}$ (2, & - & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1)*w(7) - w(2) & - & *w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7)*w(8) + w(1)**2 + w(2) & - & **2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8))) !& + & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1) & + & *w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7) & + & *w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7)) & + & *(w(2) - w(8))) !& d_cbL_${XYZ}$ (3, & - & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))) & - & !& + & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & + & *(w(1) - w(8))) !& ! Note: Left has the reversed order of both points and coefficients compared to the right y = s_cb(i + 1:i + 4) - s_cb(i:i + 3) poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 0) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 0) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) + 3*y(3)**2 + 3*y(3)*y(4) & - & + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4)) & - & *(y(1) + y(2) + y(3) + y(4))) !& + & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) & + & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 0, & - & 2) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 4*y(2)*y(3) + 2*y(4) & - & *y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & 2) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & + & + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) & + & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i:i + 3) - s_cb(i - 1:i + 2) poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 0) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) & - & !& + & 0) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 3*y(3) & - & *y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) & + & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 1, & - & 2) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & 2) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & + & + y(2) + y(3) + y(4))) !& y = s_cb(i - 1:i + 2) - s_cb(i - 2:i + 1) poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 0) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) & - & + y(3) + y(4))) !& + & 0) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 6*y(2)*y(3) & - & + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & + & + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) & + & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 2, & - & 2) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) & - & !& + & 2) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & + & + y(2) + y(3) + y(4))) !& y = s_cb(i - 2:i + 1) - s_cb(i - 3:i) poly_coef_cbR_${XYZ}$ (i + 1, 3, & - & 0) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 6*y(3)*y(4) + 2*y(1) & - & *y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4) & - & )) !& + & 0) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 & + & + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) & + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 3, & - & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) + 3*y(2)**2 & - & + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2))/((y(2) + y(3))*(y(1) + y(2) & - & + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) & + & + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2)) & + & /((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))) !& poly_coef_cbR_${XYZ}$ (i + 1, 3, & - & 2) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) & - & + y(3) + y(4))) !& + & 2) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) & + & + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i + 1:i - 2:-1) - s_cb(i:i - 3:-1) poly_coef_cbL_${XYZ}$ (i + 1, 3, & - & 2) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 2) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 3, & - & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) + 3*y(3)**2 + 3*y(3)*y(4) & - & + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4)) & - & *(y(1) + y(2) + y(3) + y(4))) !& + & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) & + & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 3, & - & 0) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 4*y(2)*y(3) + 2*y(4) & - & *y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & 0) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & + & + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) & + & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& y = s_cb(i + 2:i - 1:-1) - s_cb(i + 1:i - 2:-1) poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 2) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) & - & !& + & 2) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & + & + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 3*y(3) & - & *y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) & + & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 2, & - & 0) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & 0) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & + & + y(2) + y(3) + y(4))) !& y = s_cb(i + 3:i:-1) - s_cb(i + 2:i - 1:-1) poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 2) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) & - & + y(3) + y(4))) !& + & 2) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 + 6*y(2)*y(3) & - & + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & + & + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) & + & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 1, & - & 0) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) & - & !& + & 0) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & + & + y(2) + y(3) + y(4))) !& y = s_cb(i + 4:i + 1:-1) - s_cb(i + 3:i:-1) poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 2) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 + 6*y(3)*y(4) + 2*y(1) & - & *y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4) & - & )) !& + & 2) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 & + & + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) & + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) + 3*y(2)**2 & - & + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2))/((y(2) + y(3))*(y(1) + y(2) & - & + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) & + & + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2)) & + & /((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1, 0, & - & 0) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) + y(2) & - & + y(3) + y(4))) !& + & 0) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) & + & + y(3))*(y(1) + y(2) + y(3) + y(4))) !& poly_coef_cbL_${XYZ}$ (i + 1,:,:) = -poly_coef_cbL_${XYZ}$ (i + 1,:,:) ! Note: negative sign as the direction of taking the difference (dvd) is reversed y = s_cb(i - 2:i + 1) - s_cb(i - 3:i) beta_coef_${XYZ}$ (i + 1, 3, & - & 0) = (4*y(4)**2*(5*y(1)**2*y(2)**2 + 20*y(1)**2*y(2)*y(3) + 15*y(1)**2*y(2)*y(4) + 20*y(1) & - & **2*y(3)**2 + 30*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 10*y(1)*y(2)**3 + 60*y(1)*y(2)**2*y(3) & - & + 45*y(1)*y(2)**2*y(4) + 110*y(1)*y(2)*y(3)**2 + 165*y(1)*y(2)*y(3)*y(4) + 260*y(1)*y(2)*y(4) & - & **2 + 60*y(1)*y(3)**3 + 135*y(1)*y(3)**2*y(4) + 400*y(1)*y(3)*y(4)**2 + 225*y(1)*y(4)**3 & - & + 5*y(2)**4 + 40*y(2)**3*y(3) + 30*y(2)**3*y(4) + 110*y(2)**2*y(3)**2 + 165*y(2)**2*y(3)*y(4) & - & + 260*y(2)**2*y(4)**2 + 120*y(2)*y(3)**3 + 270*y(2)*y(3)**2*y(4) + 800*y(2)*y(3)*y(4)**2 & - & + 450*y(2)*y(4)**3 + 45*y(3)**4 + 135*y(3)**3*y(4) + 600*y(3)**2*y(4)**2 + 675*y(3)*y(4)**3 & - & + 996*y(4)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 0) = (4*y(4)**2*(5*y(1)**2*y(2)**2 + 20*y(1)**2*y(2)*y(3) + 15*y(1)**2*y(2)*y(4) & + & + 20*y(1)**2*y(3)**2 + 30*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 10*y(1)*y(2) & + & **3 + 60*y(1)*y(2)**2*y(3) + 45*y(1)*y(2)**2*y(4) + 110*y(1)*y(2)*y(3)**2 & + & + 165*y(1)*y(2)*y(3)*y(4) + 260*y(1)*y(2)*y(4)**2 + 60*y(1)*y(3)**3 + 135*y(1) & + & *y(3)**2*y(4) + 400*y(1)*y(3)*y(4)**2 + 225*y(1)*y(4)**3 + 5*y(2)**4 + 40*y(2) & + & **3*y(3) + 30*y(2)**3*y(4) + 110*y(2)**2*y(3)**2 + 165*y(2)**2*y(3)*y(4) & + & + 260*y(2)**2*y(4)**2 + 120*y(2)*y(3)**3 + 270*y(2)*y(3)**2*y(4) + 800*y(2)*y(3) & + & *y(4)**2 + 450*y(2)*y(4)**3 + 45*y(3)**4 + 135*y(3)**3*y(4) + 600*y(3)**2*y(4) & + & **2 + 675*y(3)*y(4)**3 + 996*y(4)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4)) & + & **2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 1) = -(4*y(4)**2*(10*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1)**3*y(3)**2 + 25*y(1) & - & **3*y(3)*y(4) + 105*y(1)**3*y(4)**2 + 40*y(1)**2*y(2)**2*y(3) + 20*y(1)**2*y(2)**2*y(4) & - & + 130*y(1)**2*y(2)*y(3)**2 + 155*y(1)**2*y(2)*y(3)*y(4) + 535*y(1)**2*y(2)*y(4)**2 + 90*y(1) & - & **2*y(3)**3 + 165*y(1)**2*y(3)**2*y(4) + 790*y(1)**2*y(3)*y(4)**2 + 415*y(1)**2*y(4)**3 & - & + 60*y(1)*y(2)**3*y(3) + 30*y(1)*y(2)**3*y(4) + 270*y(1)*y(2)**2*y(3)**2 + 315*y(1)*y(2)**2*y(3) & - & *y(4) + 975*y(1)*y(2)**2*y(4)**2 + 360*y(1)*y(2)*y(3)**3 + 645*y(1)*y(2)*y(3)**2*y(4) & - & + 2850*y(1)*y(2)*y(3)*y(4)**2 + 1460*y(1)*y(2)*y(4)**3 + 150*y(1)*y(3)**4 + 360*y(1)*y(3) & - & **3*y(4) + 2000*y(1)*y(3)**2*y(4)**2 + 2005*y(1)*y(3)*y(4)**3 + 2077*y(1)*y(4)**4 + 30*y(2) & - & **4*y(3) + 15*y(2)**4*y(4) + 180*y(2)**3*y(3)**2 + 210*y(2)**3*y(3)*y(4) + 650*y(2)**3*y(4)**2 & - & + 360*y(2)**2*y(3)**3 + 645*y(2)**2*y(3)**2*y(4) + 2850*y(2)**2*y(3)*y(4)**2 + 1460*y(2)**2*y(4) & - & **3 + 300*y(2)*y(3)**4 + 720*y(2)*y(3)**3*y(4) + 4000*y(2)*y(3)**2*y(4)**2 + 4010*y(2)*y(3)*y(4) & - & **3 + 4154*y(2)*y(4)**4 + 90*y(3)**5 + 270*y(3)**4*y(4) + 1800*y(3)**3*y(4)**2 + 2655*y(3) & - & **2*y(4)**3 + 4464*y(3)*y(4)**4 + 1767*y(4)**5))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) & - & + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 1) = -(4*y(4)**2*(10*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1)**3*y(3) & + & **2 + 25*y(1)**3*y(3)*y(4) + 105*y(1)**3*y(4)**2 + 40*y(1)**2*y(2)**2*y(3) & + & + 20*y(1)**2*y(2)**2*y(4) + 130*y(1)**2*y(2)*y(3)**2 + 155*y(1)**2*y(2)*y(3)*y(4) & + & + 535*y(1)**2*y(2)*y(4)**2 + 90*y(1)**2*y(3)**3 + 165*y(1)**2*y(3)**2*y(4) & + & + 790*y(1)**2*y(3)*y(4)**2 + 415*y(1)**2*y(4)**3 + 60*y(1)*y(2)**3*y(3) + 30*y(1) & + & *y(2)**3*y(4) + 270*y(1)*y(2)**2*y(3)**2 + 315*y(1)*y(2)**2*y(3)*y(4) + 975*y(1) & + & *y(2)**2*y(4)**2 + 360*y(1)*y(2)*y(3)**3 + 645*y(1)*y(2)*y(3)**2*y(4) + 2850*y(1) & + & *y(2)*y(3)*y(4)**2 + 1460*y(1)*y(2)*y(4)**3 + 150*y(1)*y(3)**4 + 360*y(1)*y(3) & + & **3*y(4) + 2000*y(1)*y(3)**2*y(4)**2 + 2005*y(1)*y(3)*y(4)**3 + 2077*y(1)*y(4) & + & **4 + 30*y(2)**4*y(3) + 15*y(2)**4*y(4) + 180*y(2)**3*y(3)**2 + 210*y(2)**3*y(3) & + & *y(4) + 650*y(2)**3*y(4)**2 + 360*y(2)**2*y(3)**3 + 645*y(2)**2*y(3)**2*y(4) & + & + 2850*y(2)**2*y(3)*y(4)**2 + 1460*y(2)**2*y(4)**3 + 300*y(2)*y(3)**4 + 720*y(2) & + & *y(3)**3*y(4) + 4000*y(2)*y(3)**2*y(4)**2 + 4010*y(2)*y(3)*y(4)**3 + 4154*y(2) & + & *y(4)**4 + 90*y(3)**5 + 270*y(3)**4*y(4) + 1800*y(3)**3*y(4)**2 + 2655*y(3) & + & **2*y(4)**3 + 4464*y(3)*y(4)**4 + 1767*y(4)**5))/(5*(y(2) + y(3))*(y(3) + y(4)) & + & *(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 2) = (4*y(4)**2*(10*y(2)**3*y(3) + 5*y(2)**3*y(4) + 50*y(2)**2*y(3)**2 + 60*y(2)**2*y(3)*y(4) & - & + 10*y(1)*y(2)**2*y(3) + 215*y(2)**2*y(4)**2 + 5*y(1)*y(2)**2*y(4) + 70*y(2)*y(3)**3 + 130*y(2) & - & *y(3)**2*y(4) + 30*y(1)*y(2)*y(3)**2 + 775*y(2)*y(3)*y(4)**2 + 35*y(1)*y(2)*y(3)*y(4) + 415*y(2) & - & *y(4)**3 + 110*y(1)*y(2)*y(4)**2 + 30*y(3)**4 + 75*y(3)**3*y(4) + 20*y(1)*y(3)**3 + 665*y(3) & - & **2*y(4)**2 + 35*y(1)*y(3)**2*y(4) + 725*y(3)*y(4)**3 + 220*y(1)*y(3)*y(4)**2 + 1767*y(4)**4 & - & + 105*y(1)*y(4)**3))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4)) & - & *(y(1) + y(2) + y(3) + y(4))**2) !& + & 2) = (4*y(4)**2*(10*y(2)**3*y(3) + 5*y(2)**3*y(4) + 50*y(2)**2*y(3)**2 + 60*y(2) & + & **2*y(3)*y(4) + 10*y(1)*y(2)**2*y(3) + 215*y(2)**2*y(4)**2 + 5*y(1)*y(2)**2*y(4) & + & + 70*y(2)*y(3)**3 + 130*y(2)*y(3)**2*y(4) + 30*y(1)*y(2)*y(3)**2 + 775*y(2)*y(3) & + & *y(4)**2 + 35*y(1)*y(2)*y(3)*y(4) + 415*y(2)*y(4)**3 + 110*y(1)*y(2)*y(4)**2 & + & + 30*y(3)**4 + 75*y(3)**3*y(4) + 20*y(1)*y(3)**3 + 665*y(3)**2*y(4)**2 + 35*y(1) & + & *y(3)**2*y(4) + 725*y(3)*y(4)**3 + 220*y(1)*y(3)*y(4)**2 + 1767*y(4)**4 & + & + 105*y(1)*y(4)**3))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 3) = (4*y(4)**2*(5*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 50*y(1)**4*y(4)**2 + 30*y(1)**3*y(2) & - & *y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 300*y(1)**3*y(2)*y(4)**2 + 30*y(1)**3*y(3)**3 + 45*y(1) & - & **3*y(3)**2*y(4) + 415*y(1)**3*y(3)*y(4)**2 + 200*y(1)**3*y(4)**3 + 75*y(1)**2*y(2)**2*y(3)**2 & - & + 75*y(1)**2*y(2)**2*y(3)*y(4) + 750*y(1)**2*y(2)**2*y(4)**2 + 150*y(1)**2*y(2)*y(3)**3 & - & + 225*y(1)**2*y(2)*y(3)**2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 1000*y(1)**2*y(2)*y(4)**3 & - & + 75*y(1)**2*y(3)**4 + 150*y(1)**2*y(3)**3*y(4) + 1390*y(1)**2*y(3)**2*y(4)**2 + 1315*y(1) & - & **2*y(3)*y(4)**3 + 1081*y(1)**2*y(4)**4 + 90*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2)**3*y(3)*y(4) & - & + 900*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1)*y(2)**2*y(3)**2*y(4) & - & + 3735*y(1)*y(2)**2*y(3)*y(4)**2 + 1800*y(1)*y(2)**2*y(4)**3 + 270*y(1)*y(2)*y(3)**4 + 540*y(1) & - & *y(2)*y(3)**3*y(4) + 5025*y(1)*y(2)*y(3)**2*y(4)**2 + 4755*y(1)*y(2)*y(3)*y(4)**3 + 4224*y(1) & - & *y(2)*y(4)**4 + 90*y(1)*y(3)**5 + 225*y(1)*y(3)**4*y(4) + 2190*y(1)*y(3)**3*y(4)**2 + 3060*y(1) & - & *y(3)**2*y(4)**3 + 4529*y(1)*y(3)*y(4)**4 + 1762*y(1)*y(4)**5 + 45*y(2)**4*y(3)**2 + 45*y(2) & - & **4*y(3)*y(4) + 450*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3)**2*y(4) + 2490*y(2) & - & **3*y(3)*y(4)**2 + 1200*y(2)**3*y(4)**3 + 270*y(2)**2*y(3)**4 + 540*y(2)**2*y(3)**3*y(4) & - & + 5025*y(2)**2*y(3)**2*y(4)**2 + 4755*y(2)**2*y(3)*y(4)**3 + 4224*y(2)**2*y(4)**4 + 180*y(2) & - & *y(3)**5 + 450*y(2)*y(3)**4*y(4) + 4380*y(2)*y(3)**3*y(4)**2 + 6120*y(2)*y(3)**2*y(4)**3 & - & + 9058*y(2)*y(3)*y(4)**4 + 3524*y(2)*y(4)**5 + 45*y(3)**6 + 135*y(3)**5*y(4) + 1395*y(3)**4*y(4) & - & **2 + 2565*y(3)**3*y(4)**3 + 4884*y(3)**2*y(4)**4 + 3624*y(3)*y(4)**5 + 831*y(4)**6))/(5*(y(2) & - & + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 3) = (4*y(4)**2*(5*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 50*y(1)**4*y(4)**2 & + & + 30*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 300*y(1)**3*y(2)*y(4)**2 & + & + 30*y(1)**3*y(3)**3 + 45*y(1)**3*y(3)**2*y(4) + 415*y(1)**3*y(3)*y(4)**2 & + & + 200*y(1)**3*y(4)**3 + 75*y(1)**2*y(2)**2*y(3)**2 + 75*y(1)**2*y(2)**2*y(3)*y(4) & + & + 750*y(1)**2*y(2)**2*y(4)**2 + 150*y(1)**2*y(2)*y(3)**3 + 225*y(1)**2*y(2)*y(3) & + & **2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 1000*y(1)**2*y(2)*y(4)**3 + 75*y(1) & + & **2*y(3)**4 + 150*y(1)**2*y(3)**3*y(4) + 1390*y(1)**2*y(3)**2*y(4)**2 + 1315*y(1) & + & **2*y(3)*y(4)**3 + 1081*y(1)**2*y(4)**4 + 90*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2) & + & **3*y(3)*y(4) + 900*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1) & + & *y(2)**2*y(3)**2*y(4) + 3735*y(1)*y(2)**2*y(3)*y(4)**2 + 1800*y(1)*y(2)**2*y(4) & + & **3 + 270*y(1)*y(2)*y(3)**4 + 540*y(1)*y(2)*y(3)**3*y(4) + 5025*y(1)*y(2)*y(3) & + & **2*y(4)**2 + 4755*y(1)*y(2)*y(3)*y(4)**3 + 4224*y(1)*y(2)*y(4)**4 + 90*y(1)*y(3) & + & **5 + 225*y(1)*y(3)**4*y(4) + 2190*y(1)*y(3)**3*y(4)**2 + 3060*y(1)*y(3)**2*y(4) & + & **3 + 4529*y(1)*y(3)*y(4)**4 + 1762*y(1)*y(4)**5 + 45*y(2)**4*y(3)**2 + 45*y(2) & + & **4*y(3)*y(4) + 450*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3) & + & **2*y(4) + 2490*y(2)**3*y(3)*y(4)**2 + 1200*y(2)**3*y(4)**3 + 270*y(2)**2*y(3) & + & **4 + 540*y(2)**2*y(3)**3*y(4) + 5025*y(2)**2*y(3)**2*y(4)**2 + 4755*y(2)**2*y(3) & + & *y(4)**3 + 4224*y(2)**2*y(4)**4 + 180*y(2)*y(3)**5 + 450*y(2)*y(3)**4*y(4) & + & + 4380*y(2)*y(3)**3*y(4)**2 + 6120*y(2)*y(3)**2*y(4)**3 + 9058*y(2)*y(3)*y(4)**4 & + & + 3524*y(2)*y(4)**5 + 45*y(3)**6 + 135*y(3)**5*y(4) + 1395*y(3)**4*y(4)**2 & + & + 2565*y(3)**3*y(4)**3 + 4884*y(3)**2*y(4)**4 + 3624*y(3)*y(4)**5 + 831*y(4)**6)) & + & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 4) = -(4*y(4)**2*(10*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 100*y(1)**2*y(2)*y(4) & - & **2 + 10*y(1)**2*y(3)**3 + 15*y(1)**2*y(3)**2*y(4) + 205*y(1)**2*y(3)*y(4)**2 + 100*y(1)**2*y(4) & - & **3 + 30*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2)**2*y(3)*y(4) + 300*y(1)*y(2)**2*y(4)**2 + 60*y(1) & - & *y(2)*y(3)**3 + 90*y(1)*y(2)*y(3)**2*y(4) + 1030*y(1)*y(2)*y(3)*y(4)**2 + 500*y(1)*y(2)*y(4)**3 & - & + 30*y(1)*y(3)**4 + 60*y(1)*y(3)**3*y(4) + 835*y(1)*y(3)**2*y(4)**2 + 805*y(1)*y(3)*y(4)**3 & - & + 1762*y(1)*y(4)**4 + 30*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 300*y(2)**3*y(4)**2 + 90*y(2) & - & **2*y(3)**3 + 135*y(2)**2*y(3)**2*y(4) + 1445*y(2)**2*y(3)*y(4)**2 + 700*y(2)**2*y(4)**3 & - & + 90*y(2)*y(3)**4 + 180*y(2)*y(3)**3*y(4) + 2205*y(2)*y(3)**2*y(4)**2 + 2115*y(2)*y(3)*y(4)**3 & - & + 3624*y(2)*y(4)**4 + 30*y(3)**5 + 75*y(3)**4*y(4) + 1060*y(3)**3*y(4)**2 + 1515*y(3)**2*y(4) & - & **3 + 3824*y(3)*y(4)**4 + 1662*y(4)**5))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3)) & - & **2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & 4) = -(4*y(4)**2*(10*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 100*y(1) & + & **2*y(2)*y(4)**2 + 10*y(1)**2*y(3)**3 + 15*y(1)**2*y(3)**2*y(4) + 205*y(1) & + & **2*y(3)*y(4)**2 + 100*y(1)**2*y(4)**3 + 30*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2) & + & **2*y(3)*y(4) + 300*y(1)*y(2)**2*y(4)**2 + 60*y(1)*y(2)*y(3)**3 + 90*y(1)*y(2) & + & *y(3)**2*y(4) + 1030*y(1)*y(2)*y(3)*y(4)**2 + 500*y(1)*y(2)*y(4)**3 + 30*y(1) & + & *y(3)**4 + 60*y(1)*y(3)**3*y(4) + 835*y(1)*y(3)**2*y(4)**2 + 805*y(1)*y(3)*y(4) & + & **3 + 1762*y(1)*y(4)**4 + 30*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 300*y(2) & + & **3*y(4)**2 + 90*y(2)**2*y(3)**3 + 135*y(2)**2*y(3)**2*y(4) + 1445*y(2)**2*y(3) & + & *y(4)**2 + 700*y(2)**2*y(4)**3 + 90*y(2)*y(3)**4 + 180*y(2)*y(3)**3*y(4) & + & + 2205*y(2)*y(3)**2*y(4)**2 + 2115*y(2)*y(3)*y(4)**3 + 3624*y(2)*y(4)**4 & + & + 30*y(3)**5 + 75*y(3)**4*y(4) + 1060*y(3)**3*y(4)**2 + 1515*y(3)**2*y(4)**3 & + & + 3824*y(3)*y(4)**4 + 1662*y(4)**5))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) & + & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 3, & - & 5) = (4*y(4)**2*(5*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 & - & + 15*y(2)*y(3)**2*y(4) + 205*y(2)*y(3)*y(4)**2 + 100*y(2)*y(4)**3 + 5*y(3)**4 + 10*y(3)**3*y(4) & - & + 205*y(3)**2*y(4)**2 + 200*y(3)*y(4)**3 + 831*y(4)**4))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3) & - & )**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 5) = (4*y(4)**2*(5*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 & + & + 10*y(2)*y(3)**3 + 15*y(2)*y(3)**2*y(4) + 205*y(2)*y(3)*y(4)**2 + 100*y(2)*y(4) & + & **3 + 5*y(3)**4 + 10*y(3)**3*y(4) + 205*y(3)**2*y(4)**2 + 200*y(3)*y(4)**3 & + & + 831*y(4)**4))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) & + & + y(4))**2) !& y = s_cb(i - 1:i + 2) - s_cb(i - 2:i + 1) beta_coef_${XYZ}$ (i + 1, 2, & - & 0) = (4*y(3)**2*(5*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 & - & + 15*y(1)*y(2)**2*y(3) + 205*y(1)*y(2)*y(3)**2 + 100*y(1)*y(3)**3 + 5*y(2)**4 + 10*y(2)**3*y(3) & - & + 205*y(2)**2*y(3)**2 + 200*y(2)*y(3)**3 + 831*y(3)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4) & - & )**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 0) = (4*y(3)**2*(5*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 & + & + 10*y(1)*y(2)**3 + 15*y(1)*y(2)**2*y(3) + 205*y(1)*y(2)*y(3)**2 + 100*y(1)*y(3) & + & **3 + 5*y(2)**4 + 10*y(2)**3*y(3) + 205*y(2)**2*y(3)**2 + 200*y(2)*y(3)**3 & + & + 831*y(3)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) & + & + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 1) = (4*y(3)**2*(5*y(1)**3*y(2)*y(3) + 10*y(1)**3*y(2)*y(4) - 95*y(1)**3*y(3)**2 + 5*y(1) & - & **3*y(3)*y(4) + 20*y(1)**2*y(2)**2*y(3) + 40*y(1)**2*y(2)**2*y(4) - 465*y(1)**2*y(2)*y(3)**2 & - & + 55*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4)**2 - 285*y(1)**2*y(3)**3 + 20*y(1)**2*y(3) & - & **2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 30*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) - 825*y(1)*y(2) & - & **2*y(3)**2 + 135*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 - 1040*y(1)*y(2)*y(3)**3 & - & + 100*y(1)*y(2)*y(3)**2*y(4) + 35*y(1)*y(2)*y(3)*y(4)**2 - 1847*y(1)*y(3)**4 + 125*y(1)*y(3) & - & **3*y(4) + 110*y(1)*y(3)**2*y(4)**2 + 15*y(2)**4*y(3) + 30*y(2)**4*y(4) - 550*y(2)**3*y(3)**2 & - & + 90*y(2)**3*y(3)*y(4) + 20*y(2)**3*y(4)**2 - 1040*y(2)**2*y(3)**3 + 100*y(2)**2*y(3)**2*y(4) & - & + 35*y(2)**2*y(3)*y(4)**2 - 3694*y(2)*y(3)**4 + 250*y(2)*y(3)**3*y(4) + 220*y(2)*y(3)**2*y(4) & - & **2 - 3219*y(3)**5 - 1452*y(3)**4*y(4) + 105*y(3)**3*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4)) & - & *(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 1) = (4*y(3)**2*(5*y(1)**3*y(2)*y(3) + 10*y(1)**3*y(2)*y(4) - 95*y(1)**3*y(3)**2 & + & + 5*y(1)**3*y(3)*y(4) + 20*y(1)**2*y(2)**2*y(3) + 40*y(1)**2*y(2)**2*y(4) & + & - 465*y(1)**2*y(2)*y(3)**2 + 55*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4)**2 & + & - 285*y(1)**2*y(3)**3 + 20*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 & + & + 30*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) - 825*y(1)*y(2)**2*y(3)**2 & + & + 135*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 - 1040*y(1)*y(2)*y(3)**3 & + & + 100*y(1)*y(2)*y(3)**2*y(4) + 35*y(1)*y(2)*y(3)*y(4)**2 - 1847*y(1)*y(3)**4 & + & + 125*y(1)*y(3)**3*y(4) + 110*y(1)*y(3)**2*y(4)**2 + 15*y(2)**4*y(3) + 30*y(2) & + & **4*y(4) - 550*y(2)**3*y(3)**2 + 90*y(2)**3*y(3)*y(4) + 20*y(2)**3*y(4)**2 & + & - 1040*y(2)**2*y(3)**3 + 100*y(2)**2*y(3)**2*y(4) + 35*y(2)**2*y(3)*y(4)**2 & + & - 3694*y(2)*y(3)**4 + 250*y(2)*y(3)**3*y(4) + 220*y(2)*y(3)**2*y(4)**2 & + & - 3219*y(3)**5 - 1452*y(3)**4*y(4) + 105*y(3)**3*y(4)**2))/(5*(y(2) + y(3))*(y(3) & + & + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4)) & + & **2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 2) = -(4*y(3)**2*(5*y(2)**3*y(3) - 95*y(2)*y(3)**3 - 190*y(2)**2*y(3)**2 + 10*y(2)**3*y(4) & - & + 100*y(3)**3*y(4) - 1562*y(3)**4 - 95*y(1)*y(2)*y(3)**2 + 5*y(1)*y(2)**2*y(3) + 10*y(1)*y(2) & - & **2*y(4) + 100*y(1)*y(3)**2*y(4) + 205*y(2)*y(3)**2*y(4) + 15*y(2)**2*y(3)*y(4) + 10*y(1)*y(2) & - & *y(3)*y(4)))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))**2) !& + & 2) = -(4*y(3)**2*(5*y(2)**3*y(3) - 95*y(2)*y(3)**3 - 190*y(2)**2*y(3)**2 & + & + 10*y(2)**3*y(4) + 100*y(3)**3*y(4) - 1562*y(3)**4 - 95*y(1)*y(2)*y(3)**2 & + & + 5*y(1)*y(2)**2*y(3) + 10*y(1)*y(2)**2*y(4) + 100*y(1)*y(3)**2*y(4) + 205*y(2) & + & *y(3)**2*y(4) + 15*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2)) & + & *(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 3) = (4*y(3)**2*(50*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 300*y(1)**3*y(2) & - & *y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 30*y(1)**3*y(2)*y(4)**2 + 200*y(1)**3*y(3)**3 + 25*y(1) & - & **3*y(3)**2*y(4) + 35*y(1)**3*y(3)*y(4)**2 + 10*y(1)**3*y(4)**3 + 750*y(1)**2*y(2)**2*y(3)**2 & - & + 75*y(1)**2*y(2)**2*y(3)*y(4) + 75*y(1)**2*y(2)**2*y(4)**2 + 1000*y(1)**2*y(2)*y(3)**3 & - & + 125*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 + 50*y(1)**2*y(2)*y(4)**3 & - & + 1081*y(1)**2*y(3)**4 - 50*y(1)**2*y(3)**3*y(4) - 10*y(1)**2*y(3)**2*y(4)**2 + 45*y(1)**2*y(3) & - & *y(4)**3 + 5*y(1)**2*y(4)**4 + 900*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2)**3*y(3)*y(4) + 90*y(1) & - & *y(2)**3*y(4)**2 + 1800*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) + 315*y(1)*y(2) & - & **2*y(3)*y(4)**2 + 90*y(1)*y(2)**2*y(4)**3 + 4224*y(1)*y(2)*y(3)**4 - 120*y(1)*y(2)*y(3)**3*y(4) & - & + 25*y(1)*y(2)*y(3)**2*y(4)**2 + 165*y(1)*y(2)*y(3)*y(4)**3 + 20*y(1)*y(2)*y(4)**4 + 3324*y(1) & - & *y(3)**5 + 1407*y(1)*y(3)**4*y(4) - 100*y(1)*y(3)**3*y(4)**2 + 70*y(1)*y(3)**2*y(4)**3 + 15*y(1) & - & *y(3)*y(4)**4 + 450*y(2)**4*y(3)**2 + 45*y(2)**4*y(3)*y(4) + 45*y(2)**4*y(4)**2 + 1200*y(2) & - & **3*y(3)**3 + 150*y(2)**3*y(3)**2*y(4) + 210*y(2)**3*y(3)*y(4)**2 + 60*y(2)**3*y(4)**3 & - & + 4224*y(2)**2*y(3)**4 - 120*y(2)**2*y(3)**3*y(4) + 25*y(2)**2*y(3)**2*y(4)**2 + 165*y(2) & - & **2*y(3)*y(4)**3 + 20*y(2)**2*y(4)**4 + 6648*y(2)*y(3)**5 + 2814*y(2)*y(3)**4*y(4) - 200*y(2) & - & *y(3)**3*y(4)**2 + 140*y(2)*y(3)**2*y(4)**3 + 30*y(2)*y(3)*y(4)**4 + 3174*y(3)**6 + 3039*y(3) & - & **5*y(4) + 771*y(3)**4*y(4)**2 + 135*y(3)**3*y(4)**3 + 60*y(3)**2*y(4)**4))/(5*(y(2) + y(3)) & - & **2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 3) = (4*y(3)**2*(50*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 & + & + 300*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 30*y(1)**3*y(2)*y(4)**2 & + & + 200*y(1)**3*y(3)**3 + 25*y(1)**3*y(3)**2*y(4) + 35*y(1)**3*y(3)*y(4)**2 & + & + 10*y(1)**3*y(4)**3 + 750*y(1)**2*y(2)**2*y(3)**2 + 75*y(1)**2*y(2)**2*y(3)*y(4) & + & + 75*y(1)**2*y(2)**2*y(4)**2 + 1000*y(1)**2*y(2)*y(3)**3 + 125*y(1)**2*y(2)*y(3) & + & **2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 + 50*y(1)**2*y(2)*y(4)**3 + 1081*y(1) & + & **2*y(3)**4 - 50*y(1)**2*y(3)**3*y(4) - 10*y(1)**2*y(3)**2*y(4)**2 + 45*y(1) & + & **2*y(3)*y(4)**3 + 5*y(1)**2*y(4)**4 + 900*y(1)*y(2)**3*y(3)**2 + 90*y(1)*y(2) & + & **3*y(3)*y(4) + 90*y(1)*y(2)**3*y(4)**2 + 1800*y(1)*y(2)**2*y(3)**3 + 225*y(1) & + & *y(2)**2*y(3)**2*y(4) + 315*y(1)*y(2)**2*y(3)*y(4)**2 + 90*y(1)*y(2)**2*y(4)**3 & + & + 4224*y(1)*y(2)*y(3)**4 - 120*y(1)*y(2)*y(3)**3*y(4) + 25*y(1)*y(2)*y(3)**2*y(4) & + & **2 + 165*y(1)*y(2)*y(3)*y(4)**3 + 20*y(1)*y(2)*y(4)**4 + 3324*y(1)*y(3)**5 & + & + 1407*y(1)*y(3)**4*y(4) - 100*y(1)*y(3)**3*y(4)**2 + 70*y(1)*y(3)**2*y(4)**3 & + & + 15*y(1)*y(3)*y(4)**4 + 450*y(2)**4*y(3)**2 + 45*y(2)**4*y(3)*y(4) + 45*y(2) & + & **4*y(4)**2 + 1200*y(2)**3*y(3)**3 + 150*y(2)**3*y(3)**2*y(4) + 210*y(2)**3*y(3) & + & *y(4)**2 + 60*y(2)**3*y(4)**3 + 4224*y(2)**2*y(3)**4 - 120*y(2)**2*y(3)**3*y(4) & + & + 25*y(2)**2*y(3)**2*y(4)**2 + 165*y(2)**2*y(3)*y(4)**3 + 20*y(2)**2*y(4)**4 & + & + 6648*y(2)*y(3)**5 + 2814*y(2)*y(3)**4*y(4) - 200*y(2)*y(3)**3*y(4)**2 & + & + 140*y(2)*y(3)**2*y(4)**3 + 30*y(2)*y(3)*y(4)**4 + 3174*y(3)**6 + 3039*y(3) & + & **5*y(4) + 771*y(3)**4*y(4)**2 + 135*y(3)**3*y(4)**3 + 60*y(3)**2*y(4)**4)) & + & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 4) = -(4*y(3)**2*(100*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 10*y(1)**2*y(2)*y(4) & - & **2 - 95*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 300*y(1)*y(2)**2*y(3)**2 + 30*y(1)*y(2) & - & **2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 + 200*y(1)*y(2)*y(3)**3 - 260*y(1)*y(2)*y(3)**2*y(4) & - & + 50*y(1)*y(2)*y(3)*y(4)**2 + 10*y(1)*y(2)*y(4)**3 + 1562*y(1)*y(3)**4 - 190*y(1)*y(3)**3*y(4) & - & + 15*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4)**3 + 300*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) & - & + 30*y(2)**3*y(4)**2 + 400*y(2)**2*y(3)**3 - 235*y(2)**2*y(3)**2*y(4) + 85*y(2)**2*y(3)*y(4)**2 & - & + 20*y(2)**2*y(4)**3 + 3224*y(2)*y(3)**4 - 460*y(2)*y(3)**3*y(4) - 35*y(2)*y(3)**2*y(4)**2 & - & + 25*y(2)*y(3)*y(4)**3 + 3124*y(3)**5 + 1467*y(3)**4*y(4) + 110*y(3)**3*y(4)**2 + 105*y(3) & - & **2*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))**2) !& + & 4) = -(4*y(3)**2*(100*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 10*y(1) & + & **2*y(2)*y(4)**2 - 95*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 300*y(1) & + & *y(2)**2*y(3)**2 + 30*y(1)*y(2)**2*y(3)*y(4) + 30*y(1)*y(2)**2*y(4)**2 + 200*y(1) & + & *y(2)*y(3)**3 - 260*y(1)*y(2)*y(3)**2*y(4) + 50*y(1)*y(2)*y(3)*y(4)**2 + 10*y(1) & + & *y(2)*y(4)**3 + 1562*y(1)*y(3)**4 - 190*y(1)*y(3)**3*y(4) + 15*y(1)*y(3)**2*y(4) & + & **2 + 5*y(1)*y(3)*y(4)**3 + 300*y(2)**3*y(3)**2 + 30*y(2)**3*y(3)*y(4) + 30*y(2) & + & **3*y(4)**2 + 400*y(2)**2*y(3)**3 - 235*y(2)**2*y(3)**2*y(4) + 85*y(2)**2*y(3) & + & *y(4)**2 + 20*y(2)**2*y(4)**3 + 3224*y(2)*y(3)**4 - 460*y(2)*y(3)**3*y(4) & + & - 35*y(2)*y(3)**2*y(4)**2 + 25*y(2)*y(3)*y(4)**3 + 3124*y(3)**5 + 1467*y(3) & + & **4*y(4) + 110*y(3)**3*y(4)**2 + 105*y(3)**2*y(4)**3))/(5*(y(1) + y(2))*(y(2) & + & + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4)) & + & **2) !& beta_coef_${XYZ}$ (i + 1, 2, & - & 5) = (4*y(3)**2*(50*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 5*y(2)**2*y(4)**2 - 95*y(2)*y(3) & - & **2*y(4) + 5*y(2)*y(3)*y(4)**2 + 781*y(3)**4 + 50*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) & - & + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 5) = (4*y(3)**2*(50*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 5*y(2)**2*y(4)**2 & + & - 95*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 781*y(3)**4 + 50*y(3)**2*y(4)**2)) & + & /(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& y = s_cb(i:i + 3) - s_cb(i - 1:i + 2) beta_coef_${XYZ}$ (i + 1, 1, & - & 0) = (4*y(2)**2*(50*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 5*y(1)**2*y(3)**2 - 95*y(1)*y(2) & - & **2*y(3) + 5*y(1)*y(2)*y(3)**2 + 781*y(2)**4 + 50*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) & - & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 0) = (4*y(2)**2*(50*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 5*y(1)**2*y(3)**2 & + & - 95*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 781*y(2)**4 + 50*y(2)**2*y(3)**2)) & + & /(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 1) = -(4*y(2)**2*(105*y(1)**3*y(2)**2 + 25*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1) & - & **3*y(3)**2 + 10*y(1)**3*y(3)*y(4) + 110*y(1)**2*y(2)**3 - 35*y(1)**2*y(2)**2*y(3) + 15*y(1) & - & **2*y(2)**2*y(4) + 85*y(1)**2*y(2)*y(3)**2 + 50*y(1)**2*y(2)*y(3)*y(4) + 5*y(1)**2*y(2)*y(4)**2 & - & + 30*y(1)**2*y(3)**3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 + 1467*y(1)*y(2)**4 & - & - 460*y(1)*y(2)**3*y(3) - 190*y(1)*y(2)**3*y(4) - 235*y(1)*y(2)**2*y(3)**2 - 260*y(1)*y(2) & - & **2*y(3)*y(4) - 95*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2)*y(3)**2*y(4) & - & + 10*y(1)*y(2)*y(3)*y(4)**2 + 3124*y(2)**5 + 3224*y(2)**4*y(3) + 1562*y(2)**4*y(4) + 400*y(2) & - & **3*y(3)**2 + 200*y(2)**3*y(3)*y(4) + 300*y(2)**2*y(3)**3 + 300*y(2)**2*y(3)**2*y(4) + 100*y(2) & - & **2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4)) & - & **2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 1) = -(4*y(2)**2*(105*y(1)**3*y(2)**2 + 25*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2) & + & *y(4) + 20*y(1)**3*y(3)**2 + 10*y(1)**3*y(3)*y(4) + 110*y(1)**2*y(2)**3 - 35*y(1) & + & **2*y(2)**2*y(3) + 15*y(1)**2*y(2)**2*y(4) + 85*y(1)**2*y(2)*y(3)**2 + 50*y(1) & + & **2*y(2)*y(3)*y(4) + 5*y(1)**2*y(2)*y(4)**2 + 30*y(1)**2*y(3)**3 + 30*y(1) & + & **2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 + 1467*y(1)*y(2)**4 - 460*y(1)*y(2) & + & **3*y(3) - 190*y(1)*y(2)**3*y(4) - 235*y(1)*y(2)**2*y(3)**2 - 260*y(1)*y(2) & + & **2*y(3)*y(4) - 95*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2) & + & *y(3)**2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 3124*y(2)**5 + 3224*y(2)**4*y(3) & + & + 1562*y(2)**4*y(4) + 400*y(2)**3*y(3)**2 + 200*y(2)**3*y(3)*y(4) + 300*y(2) & + & **2*y(3)**3 + 300*y(2)**2*y(3)**2*y(4) + 100*y(2)**2*y(3)*y(4)**2))/(5*(y(2) & + & + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 2) = -(4*y(2)**2*(100*y(1)*y(2)**3 - 190*y(2)**2*y(3)**2 + 10*y(1)*y(3)**3 + 5*y(2)*y(3)**3 & - & - 95*y(2)**3*y(3) - 1562*y(2)**4 + 15*y(1)*y(2)*y(3)**2 + 205*y(1)*y(2)**2*y(3) + 100*y(1)*y(2) & - & **2*y(4) + 10*y(1)*y(3)**2*y(4) + 5*y(2)*y(3)**2*y(4) - 95*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3) & - & *y(4)))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & 2) = -(4*y(2)**2*(100*y(1)*y(2)**3 - 190*y(2)**2*y(3)**2 + 10*y(1)*y(3)**3 & + & + 5*y(2)*y(3)**3 - 95*y(2)**3*y(3) - 1562*y(2)**4 + 15*y(1)*y(2)*y(3)**2 & + & + 205*y(1)*y(2)**2*y(3) + 100*y(1)*y(2)**2*y(4) + 10*y(1)*y(3)**2*y(4) + 5*y(2) & + & *y(3)**2*y(4) - 95*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2)) & + & *(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 3) = (4*y(2)**2*(60*y(1)**4*y(2)**2 + 30*y(1)**4*y(2)*y(3) + 15*y(1)**4*y(2)*y(4) + 20*y(1) & - & **4*y(3)**2 + 20*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 135*y(1)**3*y(2)**3 + 140*y(1)**3*y(2) & - & **2*y(3) + 70*y(1)**3*y(2)**2*y(4) + 165*y(1)**3*y(2)*y(3)**2 + 165*y(1)**3*y(2)*y(3)*y(4) & - & + 45*y(1)**3*y(2)*y(4)**2 + 60*y(1)**3*y(3)**3 + 90*y(1)**3*y(3)**2*y(4) + 50*y(1)**3*y(3)*y(4) & - & **2 + 10*y(1)**3*y(4)**3 + 771*y(1)**2*y(2)**4 - 200*y(1)**2*y(2)**3*y(3) - 100*y(1)**2*y(2) & - & **3*y(4) + 25*y(1)**2*y(2)**2*y(3)**2 + 25*y(1)**2*y(2)**2*y(3)*y(4) - 10*y(1)**2*y(2)**2*y(4) & - & **2 + 210*y(1)**2*y(2)*y(3)**3 + 315*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1)**2*y(2)*y(3)*y(4)**2 & - & + 35*y(1)**2*y(2)*y(4)**3 + 45*y(1)**2*y(3)**4 + 90*y(1)**2*y(3)**3*y(4) + 75*y(1)**2*y(3) & - & **2*y(4)**2 + 30*y(1)**2*y(3)*y(4)**3 + 5*y(1)**2*y(4)**4 + 3039*y(1)*y(2)**5 + 2814*y(1)*y(2) & - & **4*y(3) + 1407*y(1)*y(2)**4*y(4) - 120*y(1)*y(2)**3*y(3)**2 - 120*y(1)*y(2)**3*y(3)*y(4) & - & - 50*y(1)*y(2)**3*y(4)**2 + 150*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) + 125*y(1) & - & *y(2)**2*y(3)*y(4)**2 + 25*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2)*y(3) & - & **3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1)*y(2)*y(4)**4 & - & + 3174*y(2)**6 + 6648*y(2)**5*y(3) + 3324*y(2)**5*y(4) + 4224*y(2)**4*y(3)**2 + 4224*y(2) & - & **4*y(3)*y(4) + 1081*y(2)**4*y(4)**2 + 1200*y(2)**3*y(3)**3 + 1800*y(2)**3*y(3)**2*y(4) & - & + 1000*y(2)**3*y(3)*y(4)**2 + 200*y(2)**3*y(4)**3 + 450*y(2)**2*y(3)**4 + 900*y(2)**2*y(3) & - & **3*y(4) + 750*y(2)**2*y(3)**2*y(4)**2 + 300*y(2)**2*y(3)*y(4)**3 + 50*y(2)**2*y(4)**4)) & - & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4)) & - & **2) !& + & 3) = (4*y(2)**2*(60*y(1)**4*y(2)**2 + 30*y(1)**4*y(2)*y(3) + 15*y(1)**4*y(2)*y(4) & + & + 20*y(1)**4*y(3)**2 + 20*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 135*y(1) & + & **3*y(2)**3 + 140*y(1)**3*y(2)**2*y(3) + 70*y(1)**3*y(2)**2*y(4) + 165*y(1) & + & **3*y(2)*y(3)**2 + 165*y(1)**3*y(2)*y(3)*y(4) + 45*y(1)**3*y(2)*y(4)**2 + 60*y(1) & + & **3*y(3)**3 + 90*y(1)**3*y(3)**2*y(4) + 50*y(1)**3*y(3)*y(4)**2 + 10*y(1)**3*y(4) & + & **3 + 771*y(1)**2*y(2)**4 - 200*y(1)**2*y(2)**3*y(3) - 100*y(1)**2*y(2)**3*y(4) & + & + 25*y(1)**2*y(2)**2*y(3)**2 + 25*y(1)**2*y(2)**2*y(3)*y(4) - 10*y(1)**2*y(2) & + & **2*y(4)**2 + 210*y(1)**2*y(2)*y(3)**3 + 315*y(1)**2*y(2)*y(3)**2*y(4) + 175*y(1) & + & **2*y(2)*y(3)*y(4)**2 + 35*y(1)**2*y(2)*y(4)**3 + 45*y(1)**2*y(3)**4 + 90*y(1) & + & **2*y(3)**3*y(4) + 75*y(1)**2*y(3)**2*y(4)**2 + 30*y(1)**2*y(3)*y(4)**3 + 5*y(1) & + & **2*y(4)**4 + 3039*y(1)*y(2)**5 + 2814*y(1)*y(2)**4*y(3) + 1407*y(1)*y(2)**4*y(4) & + & - 120*y(1)*y(2)**3*y(3)**2 - 120*y(1)*y(2)**3*y(3)*y(4) - 50*y(1)*y(2)**3*y(4) & + & **2 + 150*y(1)*y(2)**2*y(3)**3 + 225*y(1)*y(2)**2*y(3)**2*y(4) + 125*y(1)*y(2) & + & **2*y(3)*y(4)**2 + 25*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2) & + & *y(3)**3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1) & + & *y(2)*y(4)**4 + 3174*y(2)**6 + 6648*y(2)**5*y(3) + 3324*y(2)**5*y(4) + 4224*y(2) & + & **4*y(3)**2 + 4224*y(2)**4*y(3)*y(4) + 1081*y(2)**4*y(4)**2 + 1200*y(2)**3*y(3) & + & **3 + 1800*y(2)**3*y(3)**2*y(4) + 1000*y(2)**3*y(3)*y(4)**2 + 200*y(2)**3*y(4) & + & **3 + 450*y(2)**2*y(3)**4 + 900*y(2)**2*y(3)**3*y(4) + 750*y(2)**2*y(3)**2*y(4) & + & **2 + 300*y(2)**2*y(3)*y(4)**3 + 50*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) & + & + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 4) = (4*y(2)**2*(105*y(1)**2*y(2)**3 + 220*y(1)**2*y(2)**2*y(3) + 110*y(1)**2*y(2)**2*y(4) & - & + 35*y(1)**2*y(2)*y(3)**2 + 35*y(1)**2*y(2)*y(3)*y(4) + 5*y(1)**2*y(2)*y(4)**2 + 20*y(1)**2*y(3) & - & **3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3)*y(4)**2 - 1452*y(1)*y(2)**4 + 250*y(1)*y(2) & - & **3*y(3) + 125*y(1)*y(2)**3*y(4) + 100*y(1)*y(2)**2*y(3)**2 + 100*y(1)*y(2)**2*y(3)*y(4) & - & + 20*y(1)*y(2)**2*y(4)**2 + 90*y(1)*y(2)*y(3)**3 + 135*y(1)*y(2)*y(3)**2*y(4) + 55*y(1)*y(2) & - & *y(3)*y(4)**2 + 5*y(1)*y(2)*y(4)**3 + 30*y(1)*y(3)**4 + 60*y(1)*y(3)**3*y(4) + 40*y(1)*y(3) & - & **2*y(4)**2 + 10*y(1)*y(3)*y(4)**3 - 3219*y(2)**5 - 3694*y(2)**4*y(3) - 1847*y(2)**4*y(4) & - & - 1040*y(2)**3*y(3)**2 - 1040*y(2)**3*y(3)*y(4) - 285*y(2)**3*y(4)**2 - 550*y(2)**2*y(3)**3 & - & - 825*y(2)**2*y(3)**2*y(4) - 465*y(2)**2*y(3)*y(4)**2 - 95*y(2)**2*y(4)**3 + 15*y(2)*y(3)**4 & - & + 30*y(2)*y(3)**3*y(4) + 20*y(2)*y(3)**2*y(4)**2 + 5*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) & - & + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & 4) = (4*y(2)**2*(105*y(1)**2*y(2)**3 + 220*y(1)**2*y(2)**2*y(3) + 110*y(1) & + & **2*y(2)**2*y(4) + 35*y(1)**2*y(2)*y(3)**2 + 35*y(1)**2*y(2)*y(3)*y(4) + 5*y(1) & + & **2*y(2)*y(4)**2 + 20*y(1)**2*y(3)**3 + 30*y(1)**2*y(3)**2*y(4) + 10*y(1)**2*y(3) & + & *y(4)**2 - 1452*y(1)*y(2)**4 + 250*y(1)*y(2)**3*y(3) + 125*y(1)*y(2)**3*y(4) & + & + 100*y(1)*y(2)**2*y(3)**2 + 100*y(1)*y(2)**2*y(3)*y(4) + 20*y(1)*y(2)**2*y(4) & + & **2 + 90*y(1)*y(2)*y(3)**3 + 135*y(1)*y(2)*y(3)**2*y(4) + 55*y(1)*y(2)*y(3)*y(4) & + & **2 + 5*y(1)*y(2)*y(4)**3 + 30*y(1)*y(3)**4 + 60*y(1)*y(3)**3*y(4) + 40*y(1)*y(3) & + & **2*y(4)**2 + 10*y(1)*y(3)*y(4)**3 - 3219*y(2)**5 - 3694*y(2)**4*y(3) - 1847*y(2) & + & **4*y(4) - 1040*y(2)**3*y(3)**2 - 1040*y(2)**3*y(3)*y(4) - 285*y(2)**3*y(4)**2 & + & - 550*y(2)**2*y(3)**3 - 825*y(2)**2*y(3)**2*y(4) - 465*y(2)**2*y(3)*y(4)**2 & + & - 95*y(2)**2*y(4)**3 + 15*y(2)*y(3)**4 + 30*y(2)*y(3)**3*y(4) + 20*y(2)*y(3) & + & **2*y(4)**2 + 5*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) & + & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 1, & - & 5) = (4*y(2)**2*(831*y(2)**4 + 200*y(2)**3*y(3) + 100*y(2)**3*y(4) + 205*y(2)**2*y(3)**2 & - & + 205*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 + 15*y(2)*y(3)**2*y(4) + 5*y(2) & - & *y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) & - & + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 5) = (4*y(2)**2*(831*y(2)**4 + 200*y(2)**3*y(3) + 100*y(2)**3*y(4) + 205*y(2) & + & **2*y(3)**2 + 205*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 & + & + 15*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) & + & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& y = s_cb(i + 1:i + 4) - s_cb(i:i + 3) beta_coef_${XYZ}$ (i + 1, 0, & - & 0) = (4*y(1)**2*(831*y(1)**4 + 200*y(1)**3*y(2) + 100*y(1)**3*y(3) + 205*y(1)**2*y(2)**2 & - & + 205*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 + 15*y(1)*y(2)**2*y(3) + 5*y(1) & - & *y(2)*y(3)**2 + 5*y(2)**4 + 10*y(2)**3*y(3) + 5*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) & - & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 0) = (4*y(1)**2*(831*y(1)**4 + 200*y(1)**3*y(2) + 100*y(1)**3*y(3) + 205*y(1) & + & **2*y(2)**2 + 205*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 & + & + 15*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 5*y(2)**4 + 10*y(2)**3*y(3) & + & + 5*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 1) = -(4*y(1)**2*(1662*y(1)**5 + 3824*y(1)**4*y(2) + 3624*y(1)**4*y(3) + 1762*y(1)**4*y(4) & - & + 1515*y(1)**3*y(2)**2 + 2115*y(1)**3*y(2)*y(3) + 805*y(1)**3*y(2)*y(4) + 700*y(1)**3*y(3)**2 & - & + 500*y(1)**3*y(3)*y(4) + 100*y(1)**3*y(4)**2 + 1060*y(1)**2*y(2)**3 + 2205*y(1)**2*y(2)**2*y(3) & - & + 835*y(1)**2*y(2)**2*y(4) + 1445*y(1)**2*y(2)*y(3)**2 + 1030*y(1)**2*y(2)*y(3)*y(4) + 205*y(1) & - & **2*y(2)*y(4)**2 + 300*y(1)**2*y(3)**3 + 300*y(1)**2*y(3)**2*y(4) + 100*y(1)**2*y(3)*y(4)**2 & - & + 75*y(1)*y(2)**4 + 180*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) + 135*y(1)*y(2)**2*y(3)**2 & - & + 90*y(1)*y(2)**2*y(3)*y(4) + 15*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2)*y(3)**3 + 30*y(1)*y(2)*y(3) & - & **2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 30*y(2)**5 + 90*y(2)**4*y(3) + 30*y(2)**4*y(4) + 90*y(2) & - & **3*y(3)**2 + 60*y(2)**3*y(3)*y(4) + 10*y(2)**3*y(4)**2 + 30*y(2)**2*y(3)**3 + 30*y(2)**2*y(3) & - & **2*y(4) + 10*y(2)**2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & - & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 1) = -(4*y(1)**2*(1662*y(1)**5 + 3824*y(1)**4*y(2) + 3624*y(1)**4*y(3) & + & + 1762*y(1)**4*y(4) + 1515*y(1)**3*y(2)**2 + 2115*y(1)**3*y(2)*y(3) + 805*y(1) & + & **3*y(2)*y(4) + 700*y(1)**3*y(3)**2 + 500*y(1)**3*y(3)*y(4) + 100*y(1)**3*y(4) & + & **2 + 1060*y(1)**2*y(2)**3 + 2205*y(1)**2*y(2)**2*y(3) + 835*y(1)**2*y(2)**2*y(4) & + & + 1445*y(1)**2*y(2)*y(3)**2 + 1030*y(1)**2*y(2)*y(3)*y(4) + 205*y(1)**2*y(2)*y(4) & + & **2 + 300*y(1)**2*y(3)**3 + 300*y(1)**2*y(3)**2*y(4) + 100*y(1)**2*y(3)*y(4)**2 & + & + 75*y(1)*y(2)**4 + 180*y(1)*y(2)**3*y(3) + 60*y(1)*y(2)**3*y(4) + 135*y(1)*y(2) & + & **2*y(3)**2 + 90*y(1)*y(2)**2*y(3)*y(4) + 15*y(1)*y(2)**2*y(4)**2 + 30*y(1)*y(2) & + & *y(3)**3 + 30*y(1)*y(2)*y(3)**2*y(4) + 10*y(1)*y(2)*y(3)*y(4)**2 + 30*y(2)**5 & + & + 90*y(2)**4*y(3) + 30*y(2)**4*y(4) + 90*y(2)**3*y(3)**2 + 60*y(2)**3*y(3)*y(4) & + & + 10*y(2)**3*y(4)**2 + 30*y(2)**2*y(3)**3 + 30*y(2)**2*y(3)**2*y(4) + 10*y(2) & + & **2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & + & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 2) = (4*y(1)**2*(1767*y(1)**4 + 725*y(1)**3*y(2) + 415*y(1)**3*y(3) + 105*y(4)*y(1)**3 & - & + 665*y(1)**2*y(2)**2 + 775*y(1)**2*y(2)*y(3) + 220*y(4)*y(1)**2*y(2) + 215*y(1)**2*y(3)**2 & - & + 110*y(4)*y(1)**2*y(3) + 75*y(1)*y(2)**3 + 130*y(1)*y(2)**2*y(3) + 35*y(4)*y(1)*y(2)**2 & - & + 60*y(1)*y(2)*y(3)**2 + 35*y(4)*y(1)*y(2)*y(3) + 5*y(1)*y(3)**3 + 5*y(4)*y(1)*y(3)**2 + 30*y(2) & - & **4 + 70*y(2)**3*y(3) + 20*y(4)*y(2)**3 + 50*y(2)**2*y(3)**2 + 30*y(4)*y(2)**2*y(3) + 10*y(2) & - & *y(3)**3 + 10*y(4)*y(2)*y(3)**2))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & - & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & 2) = (4*y(1)**2*(1767*y(1)**4 + 725*y(1)**3*y(2) + 415*y(1)**3*y(3) + 105*y(4) & + & *y(1)**3 + 665*y(1)**2*y(2)**2 + 775*y(1)**2*y(2)*y(3) + 220*y(4)*y(1)**2*y(2) & + & + 215*y(1)**2*y(3)**2 + 110*y(4)*y(1)**2*y(3) + 75*y(1)*y(2)**3 + 130*y(1)*y(2) & + & **2*y(3) + 35*y(4)*y(1)*y(2)**2 + 60*y(1)*y(2)*y(3)**2 + 35*y(4)*y(1)*y(2)*y(3) & + & + 5*y(1)*y(3)**3 + 5*y(4)*y(1)*y(3)**2 + 30*y(2)**4 + 70*y(2)**3*y(3) + 20*y(4) & + & *y(2)**3 + 50*y(2)**2*y(3)**2 + 30*y(4)*y(2)**2*y(3) + 10*y(2)*y(3)**3 + 10*y(4) & + & *y(2)*y(3)**2))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) & + & + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 3) = (4*y(1)**2*(831*y(1)**6 + 3624*y(1)**5*y(2) + 3524*y(1)**5*y(3) + 1762*y(1)**5*y(4) & - & + 4884*y(1)**4*y(2)**2 + 9058*y(1)**4*y(2)*y(3) + 4529*y(1)**4*y(2)*y(4) + 4224*y(1)**4*y(3)**2 & - & + 4224*y(1)**4*y(3)*y(4) + 1081*y(1)**4*y(4)**2 + 2565*y(1)**3*y(2)**3 + 6120*y(1)**3*y(2) & - & **2*y(3) + 3060*y(1)**3*y(2)**2*y(4) + 4755*y(1)**3*y(2)*y(3)**2 + 4755*y(1)**3*y(2)*y(3)*y(4) & - & + 1315*y(1)**3*y(2)*y(4)**2 + 1200*y(1)**3*y(3)**3 + 1800*y(1)**3*y(3)**2*y(4) + 1000*y(1) & - & **3*y(3)*y(4)**2 + 200*y(1)**3*y(4)**3 + 1395*y(1)**2*y(2)**4 + 4380*y(1)**2*y(2)**3*y(3) & - & + 2190*y(1)**2*y(2)**3*y(4) + 5025*y(1)**2*y(2)**2*y(3)**2 + 5025*y(1)**2*y(2)**2*y(3)*y(4) & - & + 1390*y(1)**2*y(2)**2*y(4)**2 + 2490*y(1)**2*y(2)*y(3)**3 + 3735*y(1)**2*y(2)*y(3)**2*y(4) & - & + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 415*y(1)**2*y(2)*y(4)**3 + 450*y(1)**2*y(3)**4 + 900*y(1) & - & **2*y(3)**3*y(4) + 750*y(1)**2*y(3)**2*y(4)**2 + 300*y(1)**2*y(3)*y(4)**3 + 50*y(1)**2*y(4)**4 & - & + 135*y(1)*y(2)**5 + 450*y(1)*y(2)**4*y(3) + 225*y(1)*y(2)**4*y(4) + 540*y(1)*y(2)**3*y(3)**2 & - & + 540*y(1)*y(2)**3*y(3)*y(4) + 150*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2)**2*y(3)**3 + 405*y(1) & - & *y(2)**2*y(3)**2*y(4) + 225*y(1)*y(2)**2*y(3)*y(4)**2 + 45*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2) & - & *y(3)**4 + 90*y(1)*y(2)*y(3)**3*y(4) + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 & - & + 5*y(1)*y(2)*y(4)**4 + 45*y(2)**6 + 180*y(2)**5*y(3) + 90*y(2)**5*y(4) + 270*y(2)**4*y(3)**2 & - & + 270*y(2)**4*y(3)*y(4) + 75*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2)**3*y(3)**2*y(4) & - & + 150*y(2)**3*y(3)*y(4)**2 + 30*y(2)**3*y(4)**3 + 45*y(2)**2*y(3)**4 + 90*y(2)**2*y(3)**3*y(4) & - & + 75*y(2)**2*y(3)**2*y(4)**2 + 30*y(2)**2*y(3)*y(4)**3 + 5*y(2)**2*y(4)**4))/(5*(y(2) + y(3)) & - & **2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 3) = (4*y(1)**2*(831*y(1)**6 + 3624*y(1)**5*y(2) + 3524*y(1)**5*y(3) + 1762*y(1) & + & **5*y(4) + 4884*y(1)**4*y(2)**2 + 9058*y(1)**4*y(2)*y(3) + 4529*y(1)**4*y(2)*y(4) & + & + 4224*y(1)**4*y(3)**2 + 4224*y(1)**4*y(3)*y(4) + 1081*y(1)**4*y(4)**2 & + & + 2565*y(1)**3*y(2)**3 + 6120*y(1)**3*y(2)**2*y(3) + 3060*y(1)**3*y(2)**2*y(4) & + & + 4755*y(1)**3*y(2)*y(3)**2 + 4755*y(1)**3*y(2)*y(3)*y(4) + 1315*y(1)**3*y(2) & + & *y(4)**2 + 1200*y(1)**3*y(3)**3 + 1800*y(1)**3*y(3)**2*y(4) + 1000*y(1)**3*y(3) & + & *y(4)**2 + 200*y(1)**3*y(4)**3 + 1395*y(1)**2*y(2)**4 + 4380*y(1)**2*y(2)**3*y(3) & + & + 2190*y(1)**2*y(2)**3*y(4) + 5025*y(1)**2*y(2)**2*y(3)**2 + 5025*y(1)**2*y(2) & + & **2*y(3)*y(4) + 1390*y(1)**2*y(2)**2*y(4)**2 + 2490*y(1)**2*y(2)*y(3)**3 & + & + 3735*y(1)**2*y(2)*y(3)**2*y(4) + 2075*y(1)**2*y(2)*y(3)*y(4)**2 + 415*y(1) & + & **2*y(2)*y(4)**3 + 450*y(1)**2*y(3)**4 + 900*y(1)**2*y(3)**3*y(4) + 750*y(1) & + & **2*y(3)**2*y(4)**2 + 300*y(1)**2*y(3)*y(4)**3 + 50*y(1)**2*y(4)**4 + 135*y(1) & + & *y(2)**5 + 450*y(1)*y(2)**4*y(3) + 225*y(1)*y(2)**4*y(4) + 540*y(1)*y(2)**3*y(3) & + & **2 + 540*y(1)*y(2)**3*y(3)*y(4) + 150*y(1)*y(2)**3*y(4)**2 + 270*y(1)*y(2) & + & **2*y(3)**3 + 405*y(1)*y(2)**2*y(3)**2*y(4) + 225*y(1)*y(2)**2*y(3)*y(4)**2 & + & + 45*y(1)*y(2)**2*y(4)**3 + 45*y(1)*y(2)*y(3)**4 + 90*y(1)*y(2)*y(3)**3*y(4) & + & + 75*y(1)*y(2)*y(3)**2*y(4)**2 + 30*y(1)*y(2)*y(3)*y(4)**3 + 5*y(1)*y(2)*y(4)**4 & + & + 45*y(2)**6 + 180*y(2)**5*y(3) + 90*y(2)**5*y(4) + 270*y(2)**4*y(3)**2 & + & + 270*y(2)**4*y(3)*y(4) + 75*y(2)**4*y(4)**2 + 180*y(2)**3*y(3)**3 + 270*y(2) & + & **3*y(3)**2*y(4) + 150*y(2)**3*y(3)*y(4)**2 + 30*y(2)**3*y(4)**3 + 45*y(2) & + & **2*y(3)**4 + 90*y(2)**2*y(3)**3*y(4) + 75*y(2)**2*y(3)**2*y(4)**2 + 30*y(2) & + & **2*y(3)*y(4)**3 + 5*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3)) & + & **2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 4) = -(4*y(1)**2*(1767*y(1)**5 + 4464*y(1)**4*y(2) + 4154*y(1)**4*y(3) + 2077*y(1)**4*y(4) & - & + 2655*y(1)**3*y(2)**2 + 4010*y(1)**3*y(2)*y(3) + 2005*y(1)**3*y(2)*y(4) + 1460*y(1)**3*y(3)**2 & - & + 1460*y(1)**3*y(3)*y(4) + 415*y(1)**3*y(4)**2 + 1800*y(1)**2*y(2)**3 + 4000*y(1)**2*y(2) & - & **2*y(3) + 2000*y(1)**2*y(2)**2*y(4) + 2850*y(1)**2*y(2)*y(3)**2 + 2850*y(1)**2*y(2)*y(3)*y(4) & - & + 790*y(1)**2*y(2)*y(4)**2 + 650*y(1)**2*y(3)**3 + 975*y(1)**2*y(3)**2*y(4) + 535*y(1)**2*y(3) & - & *y(4)**2 + 105*y(1)**2*y(4)**3 + 270*y(1)*y(2)**4 + 720*y(1)*y(2)**3*y(3) + 360*y(1)*y(2) & - & **3*y(4) + 645*y(1)*y(2)**2*y(3)**2 + 645*y(1)*y(2)**2*y(3)*y(4) + 165*y(1)*y(2)**2*y(4)**2 & - & + 210*y(1)*y(2)*y(3)**3 + 315*y(1)*y(2)*y(3)**2*y(4) + 155*y(1)*y(2)*y(3)*y(4)**2 + 25*y(1)*y(2) & - & *y(4)**3 + 15*y(1)*y(3)**4 + 30*y(1)*y(3)**3*y(4) + 20*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4) & - & **3 + 90*y(2)**5 + 300*y(2)**4*y(3) + 150*y(2)**4*y(4) + 360*y(2)**3*y(3)**2 + 360*y(2)**3*y(3) & - & *y(4) + 90*y(2)**3*y(4)**2 + 180*y(2)**2*y(3)**3 + 270*y(2)**2*y(3)**2*y(4) + 130*y(2)**2*y(3) & - & *y(4)**2 + 20*y(2)**2*y(4)**3 + 30*y(2)*y(3)**4 + 60*y(2)*y(3)**3*y(4) + 40*y(2)*y(3)**2*y(4) & - & **2 + 10*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & 4) = -(4*y(1)**2*(1767*y(1)**5 + 4464*y(1)**4*y(2) + 4154*y(1)**4*y(3) & + & + 2077*y(1)**4*y(4) + 2655*y(1)**3*y(2)**2 + 4010*y(1)**3*y(2)*y(3) + 2005*y(1) & + & **3*y(2)*y(4) + 1460*y(1)**3*y(3)**2 + 1460*y(1)**3*y(3)*y(4) + 415*y(1)**3*y(4) & + & **2 + 1800*y(1)**2*y(2)**3 + 4000*y(1)**2*y(2)**2*y(3) + 2000*y(1)**2*y(2) & + & **2*y(4) + 2850*y(1)**2*y(2)*y(3)**2 + 2850*y(1)**2*y(2)*y(3)*y(4) + 790*y(1) & + & **2*y(2)*y(4)**2 + 650*y(1)**2*y(3)**3 + 975*y(1)**2*y(3)**2*y(4) + 535*y(1) & + & **2*y(3)*y(4)**2 + 105*y(1)**2*y(4)**3 + 270*y(1)*y(2)**4 + 720*y(1)*y(2)**3*y(3) & + & + 360*y(1)*y(2)**3*y(4) + 645*y(1)*y(2)**2*y(3)**2 + 645*y(1)*y(2)**2*y(3)*y(4) & + & + 165*y(1)*y(2)**2*y(4)**2 + 210*y(1)*y(2)*y(3)**3 + 315*y(1)*y(2)*y(3)**2*y(4) & + & + 155*y(1)*y(2)*y(3)*y(4)**2 + 25*y(1)*y(2)*y(4)**3 + 15*y(1)*y(3)**4 + 30*y(1) & + & *y(3)**3*y(4) + 20*y(1)*y(3)**2*y(4)**2 + 5*y(1)*y(3)*y(4)**3 + 90*y(2)**5 & + & + 300*y(2)**4*y(3) + 150*y(2)**4*y(4) + 360*y(2)**3*y(3)**2 + 360*y(2)**3*y(3) & + & *y(4) + 90*y(2)**3*y(4)**2 + 180*y(2)**2*y(3)**3 + 270*y(2)**2*y(3)**2*y(4) & + & + 130*y(2)**2*y(3)*y(4)**2 + 20*y(2)**2*y(4)**3 + 30*y(2)*y(3)**4 + 60*y(2)*y(3) & + & **3*y(4) + 40*y(2)*y(3)**2*y(4)**2 + 10*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2)) & + & *(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & + & + y(4))**2) !& beta_coef_${XYZ}$ (i + 1, 0, & - & 5) = (4*y(1)**2*(996*y(1)**4 + 675*y(1)**3*y(2) + 450*y(1)**3*y(3) + 225*y(1)**3*y(4) + 600*y(1) & - & **2*y(2)**2 + 800*y(1)**2*y(2)*y(3) + 400*y(1)**2*y(2)*y(4) + 260*y(1)**2*y(3)**2 + 260*y(1) & - & **2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 135*y(1)*y(2)**3 + 270*y(1)*y(2)**2*y(3) + 135*y(1)*y(2) & - & **2*y(4) + 165*y(1)*y(2)*y(3)**2 + 165*y(1)*y(2)*y(3)*y(4) + 30*y(1)*y(2)*y(4)**2 + 30*y(1)*y(3) & - & **3 + 45*y(1)*y(3)**2*y(4) + 15*y(1)*y(3)*y(4)**2 + 45*y(2)**4 + 120*y(2)**3*y(3) + 60*y(2) & - & **3*y(4) + 110*y(2)**2*y(3)**2 + 110*y(2)**2*y(3)*y(4) + 20*y(2)**2*y(4)**2 + 40*y(2)*y(3)**3 & - & + 60*y(2)*y(3)**2*y(4) + 20*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) + 5*y(3)**2*y(4)**2) & - & )/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & 5) = (4*y(1)**2*(996*y(1)**4 + 675*y(1)**3*y(2) + 450*y(1)**3*y(3) + 225*y(1) & + & **3*y(4) + 600*y(1)**2*y(2)**2 + 800*y(1)**2*y(2)*y(3) + 400*y(1)**2*y(2)*y(4) & + & + 260*y(1)**2*y(3)**2 + 260*y(1)**2*y(3)*y(4) + 60*y(1)**2*y(4)**2 + 135*y(1) & + & *y(2)**3 + 270*y(1)*y(2)**2*y(3) + 135*y(1)*y(2)**2*y(4) + 165*y(1)*y(2)*y(3)**2 & + & + 165*y(1)*y(2)*y(3)*y(4) + 30*y(1)*y(2)*y(4)**2 + 30*y(1)*y(3)**3 + 45*y(1)*y(3) & + & **2*y(4) + 15*y(1)*y(3)*y(4)**2 + 45*y(2)**4 + 120*y(2)**3*y(3) + 60*y(2)**3*y(4) & + & + 110*y(2)**2*y(3)**2 + 110*y(2)**2*y(3)*y(4) + 20*y(2)**2*y(4)**2 + 40*y(2)*y(3) & + & **3 + 60*y(2)*y(3)**2*y(4) + 20*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) & + & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & + & + y(3) + y(4))**2) !& end do else ! TENO (only supports uniform grid) ! (Fu, et al., 2016) Table 2 (for right flux) @@ -799,17 +851,19 @@ contains ! Nullifying WENO coefficients and cell-boundary locations pointers nullify (s_cb) + end subroutine s_compute_weno_coefficients !> @brief Performs WENO reconstruction of left and right cell-boundary values from cell-averaged variables. subroutine s_weno(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, weno_dir, is1_weno_d, & + & is2_weno_d, is3_weno_d) type(scalar_field), dimension(1:), intent(in) :: v_vf real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & - & vL_rs_vf_z + & vL_rs_vf_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_rs_vf_x, vR_rs_vf_y, & - & vR_rs_vf_z + & vR_rs_vf_z integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is1_weno_d, is2_weno_d, is3_weno_d @@ -909,23 +963,23 @@ contains if (wenojs) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then ! Borges, et al. (2008) tau = abs(beta(1) - beta(0)) alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + tau/beta(0:weno_num_stencils)) + & j)*(1._wp + tau/beta(0:weno_num_stencils)) end if omega = alpha/sum(alpha) @@ -939,20 +993,20 @@ contains if (wenojs) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + tau/beta(0:weno_num_stencils)) + & j)*(1._wp + tau/beta(0:weno_num_stencils)) end if omega = alpha/sum(alpha) @@ -989,32 +1043,32 @@ contains dvd(-2) = v_rs_ws_${XYZ}$ (j - 1, k, l, i) - v_rs_ws_${XYZ}$ (j - 2, k, l, i) poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 0, & - & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(0) + & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(0) poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 1, & - & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(-1) + & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(-1) poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 2, & - & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-2) + & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-2) beta(0) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & - & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 2)*dvd(0)*dvd(0) + weno_eps + & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 2)*dvd(0)*dvd(0) + weno_eps beta(1) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & - & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 2)*dvd(-1)*dvd(-1) + weno_eps + & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 2)*dvd(-1)*dvd(-1) + weno_eps beta(2) = beta_coef_${XYZ}$ (j, 2, 0)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & - & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 2)*dvd(-2)*dvd(-2) + weno_eps + & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 2)*dvd(-2)*dvd(-2) + weno_eps if (wenojs) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then ! Borges, et al. (2008) @@ -1022,18 +1076,17 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbL_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))) & - & ! Equation 28 (note: weno_eps was already added to beta) + & j)*(1._wp + (tau/beta(q))) & + & ! Equation 28 (note: weno_eps was already added to beta) end do else if (teno) then - ! Fu, et al. (2016) - ! Fu''s code: https://dx.doi.org/10.13140/RG.2.2.36250.34247 + ! Fu, et al. (2016) Fu''s code: https://dx.doi.org/10.13140/RG.2.2.36250.34247 tau = abs(beta(2) - beta(0)) $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = 1._wp + tau/beta(q) ! Equation 22 (reuse alpha as gamma; pick C=1 & q=6) alpha(q) = (alpha(q)**3._wp) & - & **2._wp ! Equation 22 cont. (some CPU compilers cannot optimize x**6.0) + & **2._wp ! Equation 22 cont. (some CPU compilers cannot optimize x**6.0) end do omega = alpha/sum(alpha) ! Equation 25 (reuse omega as xi) @@ -1055,25 +1108,25 @@ contains ! reconstruct from right side poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 0, & - & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(0) + & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(0) poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 1, & - & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(-1) + & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(-1) poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 2, & - & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-2) + & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-2) if (wenojs) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils @@ -1129,25 +1182,23 @@ contains dvd(-3) = v_rs_ws_${XYZ}$ (j - 2, k, l, i) - v_rs_ws_${XYZ}$ (j - 3, k, l, i) poly(3) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 0, & - & 0)*dvd(2) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, & - & 0, 2)*dvd(0) + & 0)*dvd(2) + poly_coef_cbL_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, & + & 0, 2)*dvd(0) poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 1, & - & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, & - & 1, 2)*dvd(-1) + & 0)*dvd(1) + poly_coef_cbL_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, & + & 1, 2)*dvd(-1) poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 2, & - & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 2, 1)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, & - & 2, 2)*dvd(-2) + & 0)*dvd(0) + poly_coef_cbL_${XYZ}$ (j, 2, & + & 1)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 2, 2)*dvd(-2) poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbL_${XYZ}$ (j, 3, & - & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 3, & - & 1)*dvd(-2) + poly_coef_cbL_${XYZ}$ (j, 3, 2)*dvd(-3) + & 0)*dvd(-1) + poly_coef_cbL_${XYZ}$ (j, 3, & + & 1)*dvd(-2) + poly_coef_cbL_${XYZ}$ (j, 3, 2)*dvd(-3) else #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 - ! (Fu, et al., 2016) Table 1 - ! Note: Unlike TENO5, TENO7 stencils differ from WENO7 stencils - ! See Figure 2 (right) for right-sided flux (at i+1/2) - ! Here we need the left-sided flux, so we flip the weights with respect to the x=i - ! point - ! But we need to keep the stencil order to reuse the beta coefficients + ! (Fu, et al., 2016) Table 1 Note: Unlike TENO5, TENO7 stencils differ from WENO7 + ! stencils See Figure 2 (right) for right-sided flux (at i+1/2) Here we need the + ! left-sided flux, so we flip the weights with respect to the x=i point But we need + ! to keep the stencil order to reuse the beta coefficients poly(0) = (2._wp*v(-1) + 5._wp*v(0) - 1._wp*v(1))/6._wp !& poly(1) = (11._wp*v(0) - 7._wp*v(1) + 2._wp*v(2))/6._wp !& poly(2) = (-1._wp*v(-2) + 5._wp*v(-1) + 2._wp*v(0))/6._wp !& @@ -1158,42 +1209,42 @@ contains if (.not. teno) then beta(3) = beta_coef_${XYZ}$ (j, 0, 0)*dvd(2)*dvd(2) + beta_coef_${XYZ}$ (j, 0, & - & 1)*dvd(2)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & - & 2)*dvd(2)*dvd(0) + beta_coef_${XYZ}$ (j, 0, & - & 3)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & - & 4)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 5)*dvd(0)*dvd(0) + weno_eps + & 1)*dvd(2)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & + & 2)*dvd(2)*dvd(0) + beta_coef_${XYZ}$ (j, 0, & + & 3)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 0, & + & 4)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 0, 5)*dvd(0)*dvd(0) + weno_eps beta(2) = beta_coef_${XYZ}$ (j, 1, 0)*dvd(1)*dvd(1) + beta_coef_${XYZ}$ (j, 1, & - & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & - & 2)*dvd(1)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, & - & 3)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & - & 4)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 5)*dvd(-1)*dvd(-1) + weno_eps + & 1)*dvd(1)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & + & 2)*dvd(1)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, & + & 3)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 1, & + & 4)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 1, 5)*dvd(-1)*dvd(-1) + weno_eps beta(1) = beta_coef_${XYZ}$ (j, 2, 0)*dvd(0)*dvd(0) + beta_coef_${XYZ}$ (j, 2, & - & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & - & 2)*dvd(0)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, & - & 3)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & - & 4)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 5)*dvd(-2)*dvd(-2) + weno_eps + & 1)*dvd(0)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & + & 2)*dvd(0)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, & + & 3)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 2, & + & 4)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 2, 5)*dvd(-2)*dvd(-2) + weno_eps beta(0) = beta_coef_${XYZ}$ (j, 3, 0)*dvd(-1)*dvd(-1) + beta_coef_${XYZ}$ (j, 3, & - & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & - & 2)*dvd(-1)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, & - & 3)*dvd(-2)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & - & 4)*dvd(-2)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, 5)*dvd(-3)*dvd(-3) + weno_eps + & 1)*dvd(-1)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & + & 2)*dvd(-1)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, & + & 3)*dvd(-2)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & + & 4)*dvd(-2)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, 5)*dvd(-3)*dvd(-3) + weno_eps else ! TENO #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 ! High-Order Low-Dissipation Targeted ENO Schemes for Ideal Magnetohydrodynamics (Fu ! & Tang, 2019) Section 3.2 beta(0) = 13._wp/12._wp*(v(-1) - 2._wp*v(0) + v(1))**2._wp + ((v(-1) - v(1)) & - & **2._wp)/4._wp + weno_eps !& + & **2._wp)/4._wp + weno_eps !& beta(1) = 13._wp/12._wp*(v(0) - 2._wp*v(1) + v(2))**2._wp + ((3._wp*v(0) & - & - 4._wp*v(1) + v(2))**2._wp)/4._wp + weno_eps !& + & - 4._wp*v(1) + v(2))**2._wp)/4._wp + weno_eps !& beta(2) = 13._wp/12._wp*(v(-2) - 2._wp*v(-1) + v(0))**2._wp + ((v(-2) & - & - 4._wp*v(-1) + 3._wp*v(0))**2._wp)/4._wp + weno_eps !& + & - 4._wp*v(-1) + 3._wp*v(0))**2._wp)/4._wp + weno_eps !& beta(3) = (v(0)*(2107._wp*v(0) - 9402._wp*v(1) + 7042._wp*v(2) - 1854._wp*v(3)) & - & + v(1)*(11003._wp*v(1) - 17246._wp*v(2) + 4642._wp*v(3)) + v(2) & - & *(7043._wp*v(2) - 3882._wp*v(3)) + v(3)*(547._wp*v(3)))/240._wp + weno_eps !& + & + v(1)*(11003._wp*v(1) - 17246._wp*v(2) + 4642._wp*v(3)) + v(2) & + & *(7043._wp*v(2) - 3882._wp*v(3)) + v(3)*(547._wp*v(3)))/240._wp + weno_eps !& beta(4) = ( v(-3)*(547._wp*v(-3) - 3882._wp*v(-2) + 4642._wp*v(-1) & & - 1854._wp*v( 0)) & !& @@ -1209,25 +1260,24 @@ contains if (wenojs) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then - ! Castro, et al. (2010) - ! Don & Borges (2013) also helps + ! Castro, et al. (2010) Don & Borges (2013) also helps tau = abs(beta(3) - beta(0)) ! Equation 50 $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbL_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability + & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability end do else if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 @@ -1251,7 +1301,8 @@ contains omega = alpha/sum(alpha) vL_rs_vf_${XYZ}$ (j, k, l, & - & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3)*poly(3) + & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3) & + & *poly(3) if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 @@ -1261,17 +1312,17 @@ contains if (.not. teno) then poly(3) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 0, & - & 0)*dvd(2) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, & - & 0, 2)*dvd(0) + & 0)*dvd(2) + poly_coef_cbR_${XYZ}$ (j, 0, 1)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, & + & 0, 2)*dvd(0) poly(2) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 1, & - & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, & - & 1, 2)*dvd(-1) + & 0)*dvd(1) + poly_coef_cbR_${XYZ}$ (j, 1, 1)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, & + & 1, 2)*dvd(-1) poly(1) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 2, & - & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 2, 1)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, & - & 2, 2)*dvd(-2) + & 0)*dvd(0) + poly_coef_cbR_${XYZ}$ (j, 2, & + & 1)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 2, 2)*dvd(-2) poly(0) = v_rs_ws_${XYZ}$ (j, k, l, i) + poly_coef_cbR_${XYZ}$ (j, 3, & - & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 3, & - & 1)*dvd(-2) + poly_coef_cbR_${XYZ}$ (j, 3, 2)*dvd(-3) + & 0)*dvd(-1) + poly_coef_cbR_${XYZ}$ (j, 3, & + & 1)*dvd(-2) + poly_coef_cbR_${XYZ}$ (j, 3, 2)*dvd(-3) else #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 poly(0) = (-1._wp*v(-1) + 5._wp*v(0) + 2._wp*v(1))/6._wp !& @@ -1284,22 +1335,22 @@ contains if (wenojs) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) else if (mapped_weno) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)/(beta(0:weno_num_stencils)**2._wp) + & j)/(beta(0:weno_num_stencils)**2._wp) omega = alpha/sum(alpha) alpha(0:weno_num_stencils) = (d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & - & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & - & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & j)*(1._wp + d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & + & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & + & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbR_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability + & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability end do else if (teno) then $:GPU_LOOP(parallelism='[seq]') @@ -1311,7 +1362,8 @@ contains omega = alpha/sum(alpha) vR_rs_vf_${XYZ}$ (j, k, l, & - & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3)*poly(3) + & i) = omega(0)*poly(0) + omega(1)*poly(1) + omega(2)*poly(2) + omega(3) & + & *poly(3) if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 @@ -1330,24 +1382,25 @@ contains if (int_comp) then call s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, weno_dir, & - & is1_weno_d, is2_weno_d, is3_weno_d) + & is1_weno_d, is2_weno_d, is3_weno_d) end if + end subroutine s_weno !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other !! procedures that are required for the setup of the WENO reconstruction. - !! @param v_vf Cell-averaged variables - !! @param weno_dir Coordinate direction of the WENO reconstruction + !! @param v_vf Cell-averaged variables + !! @param weno_dir Coordinate direction of the WENO reconstruction subroutine s_initialize_weno(v_vf, weno_dir) + type(scalar_field), dimension(:), intent(in) :: v_vf integer, intent(in) :: weno_dir integer :: j, k, l, q - ! Determining the number of cell-average variables which will be - ! WENO-reconstructed and mapping their indical bounds in the x-, - ! y- and z-directions to those in the s1-, s2- and s3-directions - ! as to reshape the inputted data in the coordinate direction of - ! the WENO reconstruction + ! Determining the number of cell-average variables which will be WENO-reconstructed and mapping their indical bounds in the + ! x-, y- and z-directions to those in the s1-, s2- and s3-directions as to reshape the inputted data in the coordinate + ! direction of the WENO reconstruction + v_size = ubound(v_vf, 1) $:GPU_UPDATE(device='[v_size]') @@ -1398,6 +1451,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if + end subroutine s_initialize_weno !> The goal of this subroutine is to ensure that the WENO reconstruction is monotonic. The latter is achieved by enforcing @@ -1407,24 +1461,22 @@ contains !! @param vL_rs_vf Left WENO reconstructed cell-boundary values !! @param vR_rs_vf Right WENO reconstructed cell-boundary values subroutine s_preserve_monotonicity(v_rs_ws, vL_rs_vf, vR_rs_vf) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: v_rs_ws + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: v_rs_ws real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf, vR_rs_vf - integer :: i, j, k, l - real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers - real(wp) :: d_MD, d_LC !< Median (md) curvature and large curvature (LC) measures - ! The left and right upper bounds (UL), medians, large curvatures, - ! minima, and maxima of the WENO-reconstructed values of the cell- - ! average variables. + integer :: i, j, k, l + real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers + real(wp) :: d_MD, d_LC !< Median (md) curvature and large curvature (LC) measures + ! The left and right upper bounds (UL), medians, large curvatures, minima, and maxima of the WENO-reconstructed values of + ! the cell- average variables. real(wp) :: vL_UL, vR_UL real(wp) :: vL_MD, vR_MD real(wp) :: vL_LC, vR_LC real(wp) :: vL_min, vR_min real(wp) :: vL_max, vR_max real(wp), parameter :: alpha = 2._wp !> - !! Determines the maximum Courant-Friedrichs-Lewy (CFL) number that - !! may be utilized with the scheme. In theory, for stability, a CFL - !! number less than 1/(1+alpha) is necessary. The default value for - !! alpha is 2. + !! Determines the maximum Courant-Friedrichs-Lewy (CFL) number that may be utilized with the scheme. In theory, for + !! stability, a CFL number less than 1/(1+alpha) is necessary. The default value for alpha is 2. !> Determines the amount of freedom available from utilizing a large value for the local curvature. The default value for !! beta is 4/3. @@ -1442,12 +1494,12 @@ contains d(1) = v_rs_ws(j + 2, k, l, i) + v_rs_ws(j, k, l, i) - v_rs_ws(j + 1, k, l, i)*2._wp d_MD = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1)))*abs((sign(1._wp, & - & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & - & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp + & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & + & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp d_LC = (sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, 4._wp*d(1) - d(0)))*abs((sign(1._wp, & - & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & - & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp + & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & + & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp vL_UL = v_rs_ws(j, k, l, i) - (v_rs_ws(j + 1, k, l, i) - v_rs_ws(j, k, l, i))*alpha_mp @@ -1456,14 +1508,14 @@ contains vL_LC = v_rs_ws(j, k, l, i) - (v_rs_ws(j + 1, k, l, i) - v_rs_ws(j, k, l, i))*5.e-1_wp + beta_mp*d_LC vL_min = max(min(v_rs_ws(j, k, l, i), v_rs_ws(j - 1, k, l, i), vL_MD), min(v_rs_ws(j, k, l, i), vL_UL, & - & vL_LC)) + & vL_LC)) vL_max = min(max(v_rs_ws(j, k, l, i), v_rs_ws(j - 1, k, l, i), vL_MD), max(v_rs_ws(j, k, l, i), vL_UL, & - & vL_LC)) + & vL_LC)) vL_rs_vf(j, k, l, i) = vL_rs_vf(j, k, l, i) + (sign(5.e-1_wp, vL_min - vL_rs_vf(j, k, l, & - & i)) + sign(5.e-1_wp, vL_max - vL_rs_vf(j, k, l, i)))*min(abs(vL_min - vL_rs_vf(j, k, l, i)), & - & abs(vL_max - vL_rs_vf(j, k, l, i))) + & i)) + sign(5.e-1_wp, vL_max - vL_rs_vf(j, k, l, i)))*min(abs(vL_min - vL_rs_vf(j, k, l, i)), & + & abs(vL_max - vL_rs_vf(j, k, l, i))) ! END: Left Monotonicity Preserving Bound ! Right Monotonicity Preserving Bound @@ -1472,12 +1524,12 @@ contains d(1) = v_rs_ws(j + 2, k, l, i) + v_rs_ws(j, k, l, i) - v_rs_ws(j + 1, k, l, i)*2._wp d_MD = (sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, 4._wp*d(1) - d(0)))*abs((sign(1._wp, & - & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & - & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp + & 4._wp*d(0) - d(1)) + sign(1._wp, d(0)))*(sign(1._wp, 4._wp*d(0) - d(1)) + sign(1._wp, & + & d(1))))*min(abs(4._wp*d(0) - d(1)), abs(d(0)), abs(4._wp*d(1) - d(0)), abs(d(1)))/8._wp d_LC = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1)))*abs((sign(1._wp, & - & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & - & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp + & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & + & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp vR_UL = v_rs_ws(j, k, l, i) + (v_rs_ws(j, k, l, i) - v_rs_ws(j - 1, k, l, i))*alpha_mp @@ -1486,24 +1538,26 @@ contains vR_LC = v_rs_ws(j, k, l, i) + (v_rs_ws(j, k, l, i) - v_rs_ws(j - 1, k, l, i))*5.e-1_wp + beta_mp*d_LC vR_min = max(min(v_rs_ws(j, k, l, i), v_rs_ws(j + 1, k, l, i), vR_MD), min(v_rs_ws(j, k, l, i), vR_UL, & - & vR_LC)) + & vR_LC)) vR_max = min(max(v_rs_ws(j, k, l, i), v_rs_ws(j + 1, k, l, i), vR_MD), max(v_rs_ws(j, k, l, i), vR_UL, & - & vR_LC)) + & vR_LC)) vR_rs_vf(j, k, l, i) = vR_rs_vf(j, k, l, i) + (sign(5.e-1_wp, vR_min - vR_rs_vf(j, k, l, & - & i)) + sign(5.e-1_wp, vR_max - vR_rs_vf(j, k, l, i)))*min(abs(vR_min - vR_rs_vf(j, k, l, i)), & - & abs(vR_max - vR_rs_vf(j, k, l, i))) + & i)) + sign(5.e-1_wp, vR_max - vR_rs_vf(j, k, l, i)))*min(abs(vR_min - vR_rs_vf(j, k, l, i)), & + & abs(vR_max - vR_rs_vf(j, k, l, i))) ! END: Right Monotonicity Preserving Bound end do end do end do end do $:END_GPU_PARALLEL_LOOP() + end subroutine s_preserve_monotonicity !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_weno_module() + if (weno_order == 1) return ! Deallocating the WENO-stencil of the WENO-reconstructed variables @@ -1535,5 +1589,7 @@ contains @:DEALLOCATE(poly_coef_cbL_z, poly_coef_cbR_z) @:DEALLOCATE(d_cbL_z, d_cbR_z) @:DEALLOCATE(beta_coef_z) + end subroutine s_finalize_weno_module + end module m_weno diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index 842f7be582..46528ebd3f 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -9,6 +9,7 @@ !! found in the work by Perigaud and Saurel (2005). Note that both viscous and capillarity effects are only available in the volume !! fraction model. program p_main + use m_global_parameters !< Definitions of the global parameters use m_start_up use m_time_steppers @@ -68,13 +69,13 @@ program p_main if (cfl_dt) then if (mytime >= t_stop) then call s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & - & file_exists) + & file_exists) exit end if else if (t_step == t_step_stop) then call s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & - & file_exists) + & file_exists) exit end if end if diff --git a/src/syscheck/syscheck.fpp b/src/syscheck/syscheck.fpp index 7ba5543be5..c3ecad2e02 100644 --- a/src/syscheck/syscheck.fpp +++ b/src/syscheck/syscheck.fpp @@ -58,6 +58,7 @@ #:enddef OMP program syscheck + @:MPI(use mpi) @:ACC(use openacc) @:OMP(use omp_lib) @@ -104,6 +105,7 @@ program syscheck end program syscheck subroutine assert(condition) + use iso_fortran_env, only: output_unit, error_unit logical, intent(in) :: condition @@ -113,4 +115,5 @@ subroutine assert(condition) call flush (int(error_unit)) stop 1 end if + end subroutine assert From 01fd1b6ea7209d8186137ac78b7c59d9c44da75d Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 14:52:17 -0400 Subject: [PATCH 05/25] Apply ffmt: remove blanks after #ifdef, fix Fypp continuation alignment --- src/common/m_checker_common.fpp | 1 - src/common/m_chemistry.fpp | 9 +- src/common/m_model.fpp | 1 - src/common/m_mpi_common.fpp | 3 - src/common/m_nvtx.f90 | 1 - src/common/m_phase_change.fpp | 5 +- src/common/m_variables_conversion.fpp | 1 - src/post_process/m_data_input.f90 | 1 - src/post_process/m_global_parameters.fpp | 3 - src/post_process/m_mpi_proxy.fpp | 2 - src/pre_process/m_data_output.fpp | 1 - src/pre_process/m_global_parameters.fpp | 4 - src/pre_process/m_grid.f90 | 1 - src/pre_process/m_mpi_proxy.fpp | 1 - src/pre_process/m_start_up.fpp | 2 - src/simulation/m_bubbles_EL.fpp | 3 +- src/simulation/m_cbc.fpp | 7 +- src/simulation/m_data_output.fpp | 2 - src/simulation/m_fftw.fpp | 2 - src/simulation/m_global_parameters.fpp | 4 +- src/simulation/m_ib_patches.fpp | 17 ++-- src/simulation/m_ibm.fpp | 3 +- src/simulation/m_igr.fpp | 19 ++-- src/simulation/m_mpi_proxy.fpp | 1 - src/simulation/m_qbmm.fpp | 6 +- src/simulation/m_riemann_solvers.fpp | 118 +++++++++++------------ src/simulation/m_start_up.fpp | 8 +- 27 files changed, 89 insertions(+), 137 deletions(-) diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index ee805e9bd9..f159ba81e3 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -32,7 +32,6 @@ contains end subroutine s_check_inputs_common #ifndef MFC_SIMULATION - !> @brief Verifies that the total number of grid cells meets the minimum required by the number of dimensions and MPI ranks. impure subroutine s_check_total_cells diff --git a/src/common/m_chemistry.fpp b/src/common/m_chemistry.fpp index c135052d06..3390c7cda3 100644 --- a/src/common/m_chemistry.fpp +++ b/src/common/m_chemistry.fpp @@ -195,11 +195,10 @@ contains if (chem_params%transport_model == 1) then ! Note: Added 'i' and 'eqn' to private list. $:GPU_PARALLEL_LOOP(collapse=3, private='[x, y, z, i, eqn, Ys_L, Ys_R, Ys_cell, Xs_L, Xs_R, & - & mass_diffusivities_mixavg1, mass_diffusivities_mixavg2, mass_diffusivities_mixavg_Cell, h_l, & - & h_r, Xs_cell, h_k, dXk_dxi, Mass_Diffu_Flux, Mass_Diffu_Energy, MW_L, MW_R, MW_cell, Rgas_L, & - & Rgas_R, T_L, T_R, P_L, P_R, rho_L, rho_R, rho_cell, rho_Vic, lambda_L, lambda_R, & - & lambda_Cell, & - & dT_dxi, grid_spacing]', copyin='[offsets]') + & mass_diffusivities_mixavg1, mass_diffusivities_mixavg2, mass_diffusivities_mixavg_Cell, & + & h_l, h_r, Xs_cell, h_k, dXk_dxi, Mass_Diffu_Flux, Mass_Diffu_Energy, MW_L, MW_R, MW_cell, & + & Rgas_L, Rgas_R, T_L, T_R, P_L, P_R, rho_L, rho_R, rho_cell, rho_Vic, lambda_L, lambda_R, & + & lambda_Cell, dT_dxi, grid_spacing]', copyin='[offsets]') do z = isc3%beg, isc3%end do y = isc2%beg, isc2%end do x = isc1%beg, isc1%end diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index d6d467ee78..fad7554512 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -1004,7 +1004,6 @@ contains end subroutine s_distance_normals_2D #ifdef MFC_SIMULATION - subroutine s_instantiate_STL_models() ! Variables for IBM+STL diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 0f0b1f971e..a2e2febac5 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -119,7 +119,6 @@ contains integer, dimension(1) :: airfoil_glb, airfoil_loc, airfoil_start #ifdef MFC_MPI - ! Generic loop iterator integer :: i, j integer :: ierr !< Generic flag used to identify and report MPI errors @@ -202,7 +201,6 @@ contains integer, dimension(3) :: sf_start_idx #ifdef MFC_MPI - ! Generic loop iterator integer :: i, j, q, k, l, m_ds, n_ds, p_ds, ierr @@ -989,7 +987,6 @@ contains subroutine s_mpi_decompose_computational_domain #ifdef MFC_MPI - integer :: num_procs_x, num_procs_y, num_procs_z !< Optimal number of processors in the x-, y- and z-directions !> Non-optimal number of processors in the x-, y- and z-directions real(wp) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z diff --git a/src/common/m_nvtx.f90 b/src/common/m_nvtx.f90 index b6c0d64f40..4fd15ddc6e 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -28,7 +28,6 @@ module m_nvtx end type nvtxEventAttributes #if defined(MFC_GPU) && defined(__PGI) - interface nvtxRangePush ! push range with custom label and standard color subroutine nvtxRangePushA(name) bind(C, name='nvtxRangePushA') diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index d87c7810f3..3e6468752d 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -9,7 +9,6 @@ module m_phase_change #ifndef MFC_POST_PROCESS - use m_derived_types !< Definitions of the derived types use m_global_parameters !< Definitions of the global parameters use m_mpi_proxy !< Message passing interface (MPI) module proxy @@ -100,8 +99,8 @@ contains ! starting equilibrium solver - $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok, pS, pSOV, pSSL, TS, & - & TSOV, TSatOV, TSatSL, TSSL, rhoe, dynE, rhos, rho, rM, m1, m2, MCT, TvF]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok, pS, pSOV, pSSL, & + & TS, TSOV, TSatOV, TSatSL, TSSL, rhoe, dynE, rhos, rho, rM, m1, m2, MCT, TvF]') do j = 0, m do k = 0, n do l = 0, p diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index ceebbe5f0b..10f6def8fd 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -384,7 +384,6 @@ contains $:GPU_UPDATE(device='[gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs_vc]') #ifdef MFC_SIMULATION - if (viscous) then @:ALLOCATE(Res_vc(1:2, 1:Re_size_max)) do i = 1, 2 diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index 4b732bf511..33f1ef3527 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -288,7 +288,6 @@ impure subroutine s_read_parallel_data_files(t_step) integer, intent(in) :: t_step #ifdef MFC_MPI - real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb integer :: ifile, ierr, data_size, filetype, stride integer, dimension(MPI_STATUS_SIZE) :: status diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index 69f1bcf49e..e6041a954b 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -161,7 +161,6 @@ module m_global_parameters integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid integer :: num_ibs !< Number of immersed boundaries #ifdef MFC_MPI - type(mpi_io_var), public :: MPI_IO_DATA type(mpi_io_ib_var), public :: MPI_IO_IB_DATA type(mpi_io_levelset_var), public :: MPI_IO_levelset_DATA @@ -934,7 +933,6 @@ contains if (parallel_io .neqv. .true.) return #ifdef MFC_MPI - ! Option for Lustre file system (Darter/Comet/Stampede) write (mpiiofs, '(A)') '/lustre_' mpiiofs = trim(mpiiofs) @@ -975,7 +973,6 @@ contains deallocate (adv) #ifdef MFC_MPI - if (parallel_io) then deallocate (start_idx) do i = 1, sys_size diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index 39d71967d0..e96109bb61 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -29,7 +29,6 @@ contains impure subroutine s_initialize_mpi_proxy_module #ifdef MFC_MPI - integer :: i !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors ! Allocating and configuring the receive counts and the displacement vector variables used in variable-gather communication @@ -315,7 +314,6 @@ contains impure subroutine s_finalize_mpi_proxy_module #ifdef MFC_MPI - ! Deallocating the receive counts and the displacement vector variables used in variable-gather communication procedures if ((format == 1 .and. n > 0) .or. n == 0) then deallocate (recvcounts) diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index 6f27125408..6f927d8b4a 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -409,7 +409,6 @@ contains type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type #ifdef MFC_MPI - integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status integer(KIND=MPI_OFFSET_KIND) :: disp diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 5d134c167a..a1b5d1731b 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -143,7 +143,6 @@ module m_global_parameters integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid #ifdef MFC_MPI - type(mpi_io_var), public :: MPI_IO_DATA character(LEN=name_len) :: mpiiofs integer :: mpi_info_int !< MPI info for parallel IO with Lustre file systems @@ -846,7 +845,6 @@ contains & bubbles_lagrange, m, n, p, num_dims, igr, ib) #ifdef MFC_MPI - if (qbmm .and. .not. polytropic) then allocate (MPI_IO_DATA%view(1:sys_size + 2*nb*nnode)) allocate (MPI_IO_DATA%var(1:sys_size + 2*nb*nnode)) @@ -913,7 +911,6 @@ contains if (parallel_io .neqv. .true.) return #ifdef MFC_MPI - ! Option for Lustre file system (Darter/Comet/Stampede) write (mpiiofs, '(A)') '/lustre_' mpiiofs = trim(mpiiofs) @@ -947,7 +944,6 @@ contains deallocate (proc_coords) #ifdef MFC_MPI - if (parallel_io) then deallocate (start_idx) do i = 1, sys_size diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index d893ba2171..59f3479e37 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -158,7 +158,6 @@ end subroutine s_generate_serial_grid impure subroutine s_generate_parallel_grid #ifdef MFC_MPI - real(wp) :: length !< domain lengths ! Locations of cell boundaries real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb !< Locations of cell boundaries diff --git a/src/pre_process/m_mpi_proxy.fpp b/src/pre_process/m_mpi_proxy.fpp index 856143dd56..c9bb736f84 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -22,7 +22,6 @@ contains impure subroutine s_mpi_bcast_user_inputs #ifdef MFC_MPI - ! Generic loop iterator integer :: i, j ! Generic flag used to identify and report MPI errors diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index c124fd492d..b70c2907f9 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -396,7 +396,6 @@ contains impure subroutine s_read_parallel_grid_data_files #ifdef MFC_MPI - real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status @@ -496,7 +495,6 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in #ifdef MFC_MPI - integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status integer(KIND=MPI_OFFSET_KIND) :: disp diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 949d42cd4f..19f3bf85b3 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -198,8 +198,7 @@ contains $:GPU_UPDATE(device='[lag_id, bub_R0, Rmax_stats, Rmin_stats, gas_mg, gas_betaT, gas_betaC, bub_dphidt, gas_p, gas_mv, & & intfc_rad, intfc_vel, mtn_pos, mtn_posPrev, mtn_vel, mtn_s, intfc_draddt, intfc_dveldt, gas_dpdt, & - & gas_dmvdt, & - & mtn_dposdt, mtn_dveldt, nBubs]') + & gas_dmvdt, mtn_dposdt, mtn_dveldt, nBubs]') Rmax_glb = min(dflt_real, -dflt_real) Rmin_glb = max(dflt_real, -dflt_real) diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 788c3c1d5d..27b8053e7c 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -641,10 +641,9 @@ contains ! FD2 or FD4 of RHS at j = 0 $:GPU_PARALLEL_LOOP(collapse=2, private='[r, k, alpha_rho, vel, adv_local, mf, dvel_ds, dadv_ds, Re_cbc, & & dalpha_rho_ds, dpres_ds, dvel_dt, dadv_dt, dalpha_rho_dt, L, lambda, Ys, dYs_dt, dYs_ds, & - & h_k, & - & Cp_i, Gamma_i, Xs, drho_dt, dpres_dt, dpi_inf_dt, dqv_dt, dgamma_dt, rho, pres, E, H, gamma, & - & pi_inf, qv, c, Ma, T, sum_Enthalpies, Cv, Cp, e_mix, Mw, R_gas, vel_K_sum, vel_dv_dt_sum, i, & - & j]', copyin='[dir_idx]') + & h_k, Cp_i, Gamma_i, Xs, drho_dt, dpres_dt, dpi_inf_dt, dqv_dt, dgamma_dt, rho, pres, E, H, & + & gamma, pi_inf, qv, c, Ma, T, sum_Enthalpies, Cv, Cp, e_mix, Mw, R_gas, vel_K_sum, & + & vel_dv_dt_sum, i, j]', copyin='[dir_idx]') do r = is3%beg, is3%end do k = is2%beg, is2%end ! Transferring the Primitive Variables diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 1be0e73f74..aa9024d981 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -705,7 +705,6 @@ contains type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type #ifdef MFC_MPI - integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status integer(kind=MPI_OFFSET_kind) :: disp @@ -948,7 +947,6 @@ contains integer, intent(in) :: time_step #ifdef MFC_MPI - character(LEN=path_len + 2*name_len) :: file_loc integer(kind=MPI_OFFSET_kind) :: disp integer(kind=MPI_OFFSET_kind) :: m_MOK, n_MOK, p_MOK diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 757525eaa7..02dd4d33d3 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -129,7 +129,6 @@ contains if (bc_y%beg >= 0) return #if defined(MFC_GPU) - $:GPU_PARALLEL_LOOP(collapse=3) do k = 1, sys_size do j = 0, m @@ -300,7 +299,6 @@ contains @:DEALLOCATE(data_real_gpu, data_fltr_cmplx_gpu, data_cmplx_gpu) #if defined(__PGI) - ierr = cufftDestroy(fwd_plan_gpu) ierr = cufftDestroy(bwd_plan_gpu) #else diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 4748d68520..4fbefbec29 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -1255,8 +1255,7 @@ contains $:GPU_UPDATE(device='[alt_soundspeed, acoustic_source, num_source]') $:GPU_UPDATE(device='[dt, sys_size, buff_size, pref, rhoref, gamma_idx, pi_inf_idx, E_idx, alf_idx, stress_idx, mpp_lim, & & bubbles_euler, hypoelasticity, alt_soundspeed, avg_state, model_eqns, mixture_err, grid_geometry, & - & cyl_coord, & - & mp_weno, weno_eps, teno_CT, hyperelasticity, hyper_model, elasticity, xi_idx, B_idx, low_Mach]') + & cyl_coord, mp_weno, weno_eps, teno_CT, hyperelasticity, hyper_model, elasticity, xi_idx, B_idx, low_Mach]') $:GPU_UPDATE(device='[Bx0]') @@ -1328,7 +1327,6 @@ contains if (parallel_io .neqv. .true.) return #ifdef MFC_MPI - ! Option for Lustre file system (Darter/Comet/Stampede) write (mpiiofs, '(A)') '/lustre_' mpiiofs = trim(mpiiofs) diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index 0c35395c01..183060cfff 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -426,8 +426,8 @@ contains call get_bounding_indices(center(2) - ca_in, center(2) + ca_in, y_cc, jl, jr) call get_bounding_indices(center(3) - ca_in, center(3) + ca_in, z_cc, ll, lr) - $:GPU_PARALLEL_LOOP(private='[i, j, l, xyz_local, k, f]', copyin='[encoded_patch_id, center, inverse_rotation, offset, ma, & - & ca_in, airfoil_grid_u, airfoil_grid_l, z_min, z_max]', collapse=3) + $:GPU_PARALLEL_LOOP(private='[i, j, l, xyz_local, k, f]', copyin='[encoded_patch_id, center, inverse_rotation, offset, & + & ma, ca_in, airfoil_grid_u, airfoil_grid_l, z_min, z_max]', collapse=3) do l = ll, lr do j = jl, jr do i = il, ir @@ -525,8 +525,8 @@ contains ! Checking whether the rectangle covers a particular cell in the domain and verifying whether the current patch has the ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to ! this cell. - $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', & - & copyin='[encoded_patch_id, center, length, inverse_rotation, x_cc, y_cc]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', copyin='[encoded_patch_id, center, length, inverse_rotation, x_cc, & + & y_cc]', collapse=2) do j = jl, jr do i = il, ir ! get the x and y coordinates in the local IB frame @@ -793,8 +793,8 @@ contains call get_bounding_indices(center(2) - maxval(ellipse_coeffs)*2._wp, center(2) + maxval(ellipse_coeffs)*2._wp, y_cc, jl, jr) ! Checking whether the ellipse covers a particular cell in the domain - $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', copyin='[encoded_patch_id, center, ellipse_coeffs, inverse_rotation, x_cc, & - & y_cc]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', copyin='[encoded_patch_id, center, ellipse_coeffs, inverse_rotation, & + & x_cc, y_cc]', collapse=2) do j = jl, jr do i = il, ir ! get the x and y coordinates in the local IB frame @@ -871,9 +871,8 @@ contains call get_bounding_indices(bbox_min(1), bbox_max(1), x_cc, il, ir) call get_bounding_indices(bbox_min(2), bbox_max(2), y_cc, jl, jr) - $:GPU_PARALLEL_LOOP(private='[i, j, xy_local, eta]', & - & copyin='[patch_id, encoded_patch_id, center, inverse_rotation, offset, & - & spc, threshold]', collapse=2) + $:GPU_PARALLEL_LOOP(private='[i, j, xy_local, eta]', copyin='[patch_id, encoded_patch_id, center, inverse_rotation, & + & offset, spc, threshold]', collapse=2) do i = il, ir do j = jl, jr xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 5f3368657c..f486eff267 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -393,7 +393,8 @@ contains bounds_error = .false. - $:GPU_PARALLEL_LOOP(private='[q, gp, i, j, k, physical_loc, patch_id, dist, norm, dim, bound, dir, index, temp_loc, s_cc]', copy='[bounds_error]') + $:GPU_PARALLEL_LOOP(private='[q, gp, i, j, k, physical_loc, patch_id, dist, norm, dim, bound, dir, index, temp_loc, & + & s_cc]', copy='[bounds_error]') do q = 1, num_gps gp = ghost_points_in(q) i = gp%loc(1) diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index 3bd3a19d8f..cb76b4359d 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -419,8 +419,7 @@ contains #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, & - & F_R, & - & E_L, E_R, cfl, dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + & F_R, E_L, E_R, cfl, dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = 0, n do j = -1, m @@ -818,8 +817,7 @@ contains #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, & - & F_R, & - & E_L, E_R, cfl, dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + & F_R, E_L, E_R, cfl, dvel, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = 0, n do j = -1, m @@ -1308,8 +1306,7 @@ contains #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, & - & F_R, & - & E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + & F_R, E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = -1, n do j = 0, m @@ -1688,8 +1685,7 @@ contains #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, & - & F_R, & - & E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + & F_R, E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = 0, p do k = -1, n do j = 0, m @@ -2152,10 +2148,9 @@ contains end if else if (idir == 3) then #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, mu_R, & - & vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, E_L, & - & E_R, & - & cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[j, k, l, rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, mu_L, & + & mu_R, vel_L, vel_R, pres_L, pres_R, alpha_L, alpha_R, alpha_rho_L, alpha_rho_R, F_L, F_R, & + & E_L, E_R, cfl, dvel_small, rho_sf_small, vflux_L_arr, vflux_R_arr]') do l = -1, p do k = 0, n do j = 0, m diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index ff0587c9c3..a3c72caae8 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -62,7 +62,6 @@ contains impure subroutine s_mpi_bcast_user_inputs() #ifdef MFC_MPI - integer :: i, j !< Generic loop iterator integer :: ierr !< Generic flag used to identify and report MPI errors diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index 496b90d160..2da6328873 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -765,9 +765,9 @@ contains is1_qbmm = ix; is2_qbmm = iy; is3_qbmm = iz $:GPU_UPDATE(device='[is1_qbmm, is2_qbmm, is3_qbmm]') - $:GPU_PARALLEL_LOOP(collapse=3, private='[id1, id2, id3, moms, msum, wght, abscX, abscY, wght_pb, wght_mv, wght_ht, coeff, & - & ht, r, q, n_tait, B_tait, pres, rho, nbub, c, alf, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, & - & grad_T, i1, i2, j]') + $:GPU_PARALLEL_LOOP(collapse=3, private='[id1, id2, id3, moms, msum, wght, abscX, abscY, wght_pb, wght_mv, wght_ht, & + & coeff, ht, r, q, n_tait, B_tait, pres, rho, nbub, c, alf, momsum, drdt, drdt2, chi_vw, x_vw, & + & rho_mw, k_mw, grad_T, i1, i2, j]') do id3 = is3_qbmm%beg, is3_qbmm%end do id2 = is2_qbmm%beg, is2_qbmm%end do id1 = is1_qbmm%beg, is1_qbmm%end diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index aa9c86624b..e0dc65d5f4 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -244,17 +244,15 @@ contains call s_initialize_riemann_solver(flux_src_vf, norm_dir) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] 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, & + $: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]') + & 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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -933,16 +931,15 @@ contains call s_initialize_riemann_solver(flux_src_vf, norm_dir) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] 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]') + $: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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -1427,8 +1424,8 @@ contains #:endfor if (viscous .or. dummy) 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]') + $: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 @@ -1848,16 +1845,14 @@ contains ! ME3 $: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_MP, xi_PP]') + & 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_MP, xi_PP]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -2257,13 +2252,13 @@ contains else if (model_eqns == 4) then ! ME4 $: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_MP, xi_PP]') + & 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_MP, xi_PP]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -2473,14 +2468,13 @@ contains end do $:END_GPU_PARALLEL_LOOP() else if (model_eqns == 2 .and. bubbles_euler) then - $: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_MP, xi_PP, nbub_L, nbub_R, PbwR3Lbar, PbwR3Rbar, R3Lbar, R3Rbar, & - & R3V2Lbar, R3V2Rbar]') + $: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_MP, xi_PP, nbub_L, nbub_R, PbwR3Lbar, PbwR3Rbar, R3Lbar, R3Rbar, & + & R3V2Lbar, R3V2Rbar]') do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -2868,16 +2862,14 @@ contains $:END_GPU_PARALLEL_LOOP() else ! 5-EQUATION MODEL WITH HLLC - $: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, 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]') + $: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, 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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end @@ -3406,12 +3398,12 @@ contains #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] 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]') + $: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 = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 4148a48424..816f529971 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -322,7 +322,6 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf #ifdef MFC_MPI - real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status @@ -1090,10 +1089,9 @@ contains $:GPU_UPDATE(device='[chem_params]') $:GPU_UPDATE(device='[R0ref, p0ref, rho0ref, ss, pv, vd, mu_l, mu_v, mu_g, gam_v, gam_g, M_v, M_g, R_v, R_g, Tw, cp_v, & - & cp_g, k_vl, k_gl, gam, gam_m, Eu, Ca, Web, Re_inv, Pe_c, phi_vg, phi_gv, omegaN, bubbles_euler, polytropic, & - & polydisperse, qbmm, ptil, bubble_model, thermal, poly_sigma, adv_n, adap_dt, adap_dt_tol, & - & adap_dt_max_iters, & - & n_idx, pi_fac, low_Mach]') + & cp_g, k_vl, k_gl, gam, gam_m, Eu, Ca, Web, Re_inv, Pe_c, phi_vg, phi_gv, omegaN, bubbles_euler, & + & polytropic, polydisperse, qbmm, ptil, bubble_model, thermal, poly_sigma, adv_n, adap_dt, adap_dt_tol, & + & adap_dt_max_iters, n_idx, pi_fac, low_Mach]') if (bubbles_euler) then $:GPU_UPDATE(device='[weight, R0]') From 91eabae3f329a2a0ae85233066c49c59a1792602 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 15:12:03 -0400 Subject: [PATCH 06/25] Apply ffmt: fix blank lines after #ifdef in declaration regions --- src/common/m_boundary_common.fpp | 1 + src/common/m_chemistry.fpp | 2 ++ src/common/m_compile_specific.f90 | 4 ---- src/common/m_mpi_common.fpp | 1 - src/common/m_nvtx.f90 | 1 - src/common/m_phase_change.fpp | 1 + src/common/m_variables_conversion.fpp | 2 ++ src/post_process/m_data_output.fpp | 1 - src/post_process/m_start_up.fpp | 3 --- src/pre_process/m_assign_variables.fpp | 1 + src/pre_process/m_icpp_patches.fpp | 19 +++++++++++++++++++ src/simulation/m_body_forces.fpp | 1 - src/simulation/m_bubbles_EE.fpp | 1 + src/simulation/m_bubbles_EL.fpp | 1 + src/simulation/m_cbc.fpp | 1 + src/simulation/m_data_output.fpp | 1 + src/simulation/m_global_parameters.fpp | 1 - src/simulation/m_hyperelastic.fpp | 1 + src/simulation/m_ib_patches.fpp | 1 + src/simulation/m_ibm.fpp | 2 ++ src/simulation/m_muscl.fpp | 1 - src/simulation/m_qbmm.fpp | 2 +- src/simulation/m_rhs.fpp | 2 -- src/simulation/m_riemann_solvers.fpp | 6 +++++- src/simulation/m_start_up.fpp | 1 + src/simulation/m_surface_tension.fpp | 2 +- src/simulation/m_time_steppers.fpp | 2 +- src/simulation/m_viscous.fpp | 4 ++-- 28 files changed, 45 insertions(+), 21 deletions(-) diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 1fffd160b0..2b5eae1d12 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -1858,6 +1858,7 @@ contains subroutine s_populate_grid_variables_buffers integer :: i !< Generic loop iterator + #ifdef MFC_SIMULATION ! Required for compatibility between codes type(int_bounds_info) :: offset_x, offset_y, offset_z diff --git a/src/common/m_chemistry.fpp b/src/common/m_chemistry.fpp index 3390c7cda3..7ffb622e13 100644 --- a/src/common/m_chemistry.fpp +++ b/src/common/m_chemistry.fpp @@ -117,6 +117,7 @@ contains integer :: eqn real(wp) :: T real(wp) :: rho, omega_m + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(10) :: Ys real(wp), dimension(10) :: omega @@ -162,6 +163,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf type(int_bounds_info), intent(in) :: irx, iry, irz integer, intent(in) :: idir + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(10) :: Xs_L, Xs_R, Xs_cell, Ys_L, Ys_R, Ys_cell real(wp), dimension(10) :: mass_diffusivities_mixavg1, mass_diffusivities_mixavg2 diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index da6158e972..b5b86c111c 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -19,7 +19,6 @@ impure subroutine s_create_directory(dir_name) character(LEN=*), intent(in) :: dir_name #ifdef _WIN32 - call system('mkdir "' // dir_name // '" 2> NUL') #else call system('mkdir -p "' // dir_name // '"') @@ -33,7 +32,6 @@ impure subroutine s_delete_file(filepath) character(LEN=*), intent(in) :: filepath #ifdef _WIN32 - call system('del "' // filepath // '"') #else call system('rm "' // filepath // '"') @@ -47,7 +45,6 @@ impure subroutine s_delete_directory(dir_name) character(LEN=*), intent(in) :: dir_name #ifdef _WIN32 - call system('rmdir "' // dir_name // '" /s /q') #else call system('rm -r "' // dir_name // '"') @@ -64,7 +61,6 @@ impure subroutine my_inquire(fileloc, dircheck) logical, intent(inout) :: dircheck #ifdef __INTEL_COMPILER - inquire (DIRECTORY=trim(fileloc), EXIST=dircheck) ! Intel #else inquire (FILE=trim(fileloc), EXIST=dircheck) ! GCC diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index a2e2febac5..72a9665fd6 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -252,7 +252,6 @@ contains integer, allocatable :: recounts(:), displs(:) #ifdef MFC_MPI - allocate (recounts(num_procs)) call MPI_GATHER(counts, 1, MPI_INTEGER, recounts, 1, MPI_INTEGER, root, MPI_COMM_WORLD, ierr) diff --git a/src/common/m_nvtx.f90 b/src/common/m_nvtx.f90 index 4fd15ddc6e..203d3389af 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -65,7 +65,6 @@ subroutine nvtxStartRange(name, id) type(nvtxEventAttributes) :: event #if defined(MFC_GPU) && defined(__PGI) - tempName = trim(name) // c_null_char if (.not. present(id)) then diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index 3e6468752d..e76d815fc4 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -80,6 +80,7 @@ contains real(wp) :: TvF !< total volume fraction ! $:GPU_DECLARE(create='[pS,pSOV,pSSL,TS,TSOV,TSSL,TSatOV,TSatSL]') ! $:GPU_DECLARE(create='[rhoe,dynE,rhos,rho,rM,m1,m2,MCT,TvF]') + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: p_infOV, p_infpT, p_infSL, sk, hk, gk, ek, rhok #:else diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 10f6def8fd..7746c22c45 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -512,6 +512,7 @@ contains type(scalar_field), intent(inout) :: q_T_sf type(scalar_field), dimension(sys_size), intent(inout) :: qK_prim_vf type(int_bounds_info), dimension(1:3), intent(in) :: ibounds + #:if USING_AMD and not MFC_CASE_OPTIMIZATION real(wp), dimension(3) :: alpha_K, alpha_rho_K real(wp), dimension(3) :: nRtmp @@ -1072,6 +1073,7 @@ contains ! Partial densities, density, velocity, pressure, energy, advection variables, the specific heat ratio and liquid stiffness ! functions, the shear and volume Reynolds numbers and the Weber numbers + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha_rho_K real(wp), dimension(3) :: alpha_K diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index d08d522c37..623af38e11 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -374,7 +374,6 @@ contains integer :: lower_bound, upper_bound #:for X, M in [('x', 'm'), ('y', 'n'), ('z', 'p')] - if (${M}$ == 0) return ! Early return for y or z if simulation is 1D or 2D lower_bound = -offset_${X}$%beg diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 327d89dfac..01380592b3 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -801,7 +801,6 @@ contains integer :: i, j, k, l #ifdef MFC_MPI - allocate (sendbuf(Nx*Nyloc*Nzloc)) allocate (recvbuf(Nx*Nyloc*Nzloc)) @@ -844,7 +843,6 @@ contains integer :: j, k, l #ifdef MFC_MPI - allocate (sendbuf(Ny*Nxloc*Nzloc)) allocate (recvbuf(Ny*Nxloc*Nzloc)) @@ -977,7 +975,6 @@ contains integer :: j, k, l #ifdef MFC_MPI - do l = 1, Nzloc do k = 1, Nyloc do j = 1, Nx diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index 6d29c184db..fa13d980b1 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -43,6 +43,7 @@ module m_assign_variables integer, intent(in) :: j, k, l real(wp), intent(in) :: eta type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index f3d98a3e67..9b05178a98 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -53,6 +53,7 @@ contains impure subroutine s_apply_icpp_patches(patch_id_fp, q_prim_vf) type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -171,6 +172,7 @@ contains subroutine s_icpp_line_segment(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -236,6 +238,7 @@ contains impure subroutine s_icpp_spiral(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -303,6 +306,7 @@ contains subroutine s_icpp_circle(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -360,6 +364,7 @@ contains ! Patch identifier integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -421,6 +426,7 @@ contains ! Patch identifier integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -488,6 +494,7 @@ contains subroutine s_icpp_ellipse(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -549,6 +556,7 @@ contains ! Patch identifier integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -626,6 +634,7 @@ contains subroutine s_icpp_rectangle(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -701,6 +710,7 @@ contains subroutine s_icpp_sweep_line(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -763,6 +773,7 @@ contains subroutine s_icpp_2D_TaylorGreen_Vortex(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -839,6 +850,7 @@ contains ! Patch identifier integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -895,6 +907,7 @@ contains subroutine s_icpp_2d_modal(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -949,6 +962,7 @@ contains subroutine s_icpp_3d_spherical_harmonic(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -1015,6 +1029,7 @@ contains subroutine s_icpp_sphere(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -1089,6 +1104,7 @@ contains subroutine s_icpp_cuboid(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -1164,6 +1180,7 @@ contains subroutine s_icpp_cylinder(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -1264,6 +1281,7 @@ contains subroutine s_icpp_sweep_plane(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else @@ -1337,6 +1355,7 @@ contains subroutine s_icpp_model(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id + #ifdef MFC_MIXED_PRECISION integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #else diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index 1950db63b1..3fb81d3dcb 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -49,7 +49,6 @@ contains real(wp), intent(in) :: t #:for DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (bf_${XYZ}$) then accel_bf(${DIR}$) = g_${XYZ}$ + k_${XYZ}$*sin(w_${XYZ}$*t - p_${XYZ}$) end if diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index 47d4bade61..03c34e2b10 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -152,6 +152,7 @@ contains real(wp) :: rddot real(wp) :: pb_local, mv_local, vflux, pbdot real(wp) :: n_tait, B_tait + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: Rtmp, Vtmp real(wp), dimension(3) :: myalpha, myalpha_rho diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 19f3bf85b3..a119f60bb6 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -503,6 +503,7 @@ contains real(wp) :: myR, myV, myBeta_c, myBeta_t, myR0, myPbdot, myMvdot real(wp) :: myPinf, aux1, aux2, myCson, myRho real(wp) :: gamma, pi_inf, qv + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: myalpha_rho, myalpha #:else diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 27b8053e7c..9abd7b526b 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -520,6 +520,7 @@ contains real(wp) :: dpi_inf_dt real(wp) :: dqv_dt real(wp) :: dpres_ds + #:if USING_AMD real(wp), dimension(20) :: L #:else diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index aa9024d981..a9411261af 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -200,6 +200,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf integer, intent(in) :: t_step real(wp) :: rho !< Cell-avg. density + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction real(wp), dimension(3) :: vel !< Cell-avg. velocity diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 4fbefbec29..3a4d0af917 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -1312,7 +1312,6 @@ contains #endif #:if not MFC_CASE_OPTIMIZATION - num_dims = 1 + min(1, n) + min(1, p) if (mhd) then diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index fb9ddaed4d..db355a1233 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -82,6 +82,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + #:if USING_AMD real(wp), dimension(10) :: tensora, tensorb #:else diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index 183060cfff..18abe9bdde 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -1151,6 +1151,7 @@ contains integer, intent(out), optional :: zp_lower, zp_upper ! check domain wraps in x, y + #:for X in [('x'), ('y')] ! check for periodicity diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index f486eff267..86c155c81a 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -138,6 +138,7 @@ contains real(wp) :: pres_IP real(wp), dimension(3) :: vel_IP, vel_norm_IP real(wp) :: c_IP + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: Gs real(wp), dimension(3) :: alpha_rho_IP, alpha_IP @@ -915,6 +916,7 @@ contains & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations real(wp), dimension(1:3) :: local_force_contribution, radial_vector, local_torque_contribution, vel real(wp) :: cell_volume, dx, dy, dz, dynamic_viscosity + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: dynamic_viscosities #:else diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index f7d4e23cbe..98e9e0c47a 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -229,7 +229,6 @@ contains real(wp) :: aCL, aCR, aC, aTHINC, qmin, qmax, A, B, C, sign, moncon #:for MUSCL_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (muscl_dir == ${MUSCL_DIR}$) then $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, aCL, aC, aCR, aTHINC, moncon, sign, qmin, qmax]') do l = is3_muscl%beg, is3_muscl%end diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index 2da6328873..eac335a29d 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -44,7 +44,6 @@ contains integer :: i1, i2, q, i, j #:if not MFC_CASE_OPTIMIZATION - if (bubble_model == 2) then ! Keller-Miksis without viscosity/surface tension nterms = 32 @@ -746,6 +745,7 @@ contains real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: mv real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv type(int_bounds_info), intent(in) :: ix, iy, iz + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(6) :: moms, msum real(wp), dimension(4, 3) :: wght, abscX, abscY, wght_pb, wght_mv, wght_ht, ht diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index ba7af08ddf..fe92276655 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -1668,7 +1668,6 @@ contains integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] - if (recon_type == ${TYPE}$ .or. dummy) then ! Reconstruction in s1-direction if (norm_dir == 1) then @@ -1717,7 +1716,6 @@ contains ! Reconstruction in s1-direction #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl', 'MUSCL_TYPE')] - if (recon_type == ${TYPE}$ .or. dummy) then if (norm_dir == 1) then is1 = idwbuff(1); is2 = idwbuff(2); is3 = idwbuff(3) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index e0dc65d5f4..c6f992b62a 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -125,7 +125,6 @@ contains type(int_bounds_info), intent(in) :: ix, iy, iz #:for NAME, NUM in [('hll', 1), ('hllc', 2), ('hlld', 4), ('lf', 5)] - if (riemann_solver == ${NUM}$) then call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & @@ -178,6 +177,7 @@ contains 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 @@ -862,6 +862,7 @@ contains 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 @@ -3362,6 +3363,7 @@ contains 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 @@ -4212,6 +4214,7 @@ contains 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). @@ -4393,6 +4396,7 @@ contains 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. diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 816f529971..a45f883bbe 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -993,6 +993,7 @@ contains impure subroutine s_initialize_mpi_domain integer :: ierr + #ifdef MFC_GPU real(wp) :: starttime, endtime integer :: num_devices, local_size, num_nodes, ppn, my_device_num diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index 52cffffd54..fc07b6b02b 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -75,6 +75,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf integer, intent(in) :: id type(int_bounds_info), intent(in) :: isx, isy, isz + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3, 3) :: Omega #:else @@ -300,7 +301,6 @@ contains integer :: i, j, k, l #:for SCHEME, TYPE in [('weno', 'WENO_TYPE'),('muscl', 'MUSCL_TYPE')] - if (recon_type == ${TYPE}$ .or. dummy) then ! Reconstruction in s1-direction diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index cf3cc388d6..63fe4dd9b4 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -629,6 +629,7 @@ contains impure subroutine s_compute_dt() real(wp) :: rho !< Cell-avg. density + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: vel !< Cell-avg. velocity real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction @@ -870,7 +871,6 @@ contains integer :: i, j !< Generic loop iterators ! Deallocating the cell-average conservative variables #if defined(__NVCOMPILER_GPU_UNIFIED_MEM) - do j = 1, sys_size @:DEALLOCATE(q_cons_ts(1)%vf(j)%sf) if (num_ts == 2) then diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index e08fd2e079..42c84da9bf 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -56,6 +56,7 @@ contains type(int_bounds_info), intent(in) :: ix, iy, iz real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables real(wp), dimension(2) :: Re_visc + #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(3) :: alpha_visc, alpha_rho_visc real(wp), dimension(3, 3) :: tau_Re @@ -885,7 +886,6 @@ contains integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] - if (recon_type == ${TYPE}$ .or. dummy) then ! Reconstruction in s1-direction @@ -981,8 +981,8 @@ contains integer, intent(in) :: norm_dir integer :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l - #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] + #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] if (recon_type == ${TYPE}$) then ! Reconstruction in s1-direction From 023a5b473cf352e109dd4402169e5bb91034002b Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 15:16:03 -0400 Subject: [PATCH 07/25] Apply ffmt: remove blank lines after #else/#elif continuations --- src/common/include/3dHardcodedIC.fpp | 1 - src/common/m_mpi_common.fpp | 15 --------------- src/common/m_phase_change.fpp | 2 -- src/common/m_variables_conversion.fpp | 3 --- src/post_process/m_data_output.fpp | 4 ---- src/post_process/m_global_parameters.fpp | 1 - src/post_process/m_mpi_proxy.fpp | 2 -- src/pre_process/m_grid.f90 | 1 - src/pre_process/m_icpp_patches.fpp | 1 - src/simulation/m_bubbles_EL.fpp | 1 - src/simulation/m_bubbles_EL_kernels.fpp | 1 - src/simulation/m_cbc.fpp | 5 ----- src/simulation/m_fftw.fpp | 1 - src/simulation/m_global_parameters.fpp | 1 - src/simulation/m_ibm.fpp | 1 - src/simulation/m_rhs.fpp | 5 ----- src/simulation/m_riemann_solvers.fpp | 3 --- src/simulation/m_start_up.fpp | 1 - src/simulation/m_viscous.fpp | 5 ----- src/simulation/m_weno.fpp | 1 - 20 files changed, 55 deletions(-) diff --git a/src/common/include/3dHardcodedIC.fpp b/src/common/include/3dHardcodedIC.fpp index 07a6dca8eb..1e9854b579 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -140,7 +140,6 @@ q_prim_vf(E_idx)%sf(i, j, k) = p_th*rcut*xcut + p_am case (303) ! 3D Multijet - eps_smooth = 3.0_wp ux_th = 10*sqrt(1.4*0.4) ux_am = 2.5*sqrt(1.4*0.4) diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 72a9665fd6..124a935eb8 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -334,7 +334,6 @@ contains call MPI_REDUCE(Rc_min_loc, Rc_min_glb, 1, mpi_p, MPI_MIN, 0, MPI_COMM_WORLD, ierr) end if #else - icfl_max_glb = icfl_max_loc if (viscous) then @@ -1046,7 +1045,6 @@ contains end if end do else - if (cyl_coord .and. p > 0) then ! Implement pencil processor blocking if using cylindrical coordinates so that all cells in azimuthal ! direction are stored on a single processor. This is necessary for efficient application of Fourier filter @@ -1080,7 +1078,6 @@ contains end if end do else - ! Initial estimate of optimal processor topology num_procs_x = 1 num_procs_y = 1 @@ -1206,7 +1203,6 @@ contains ! 2D Cartesian Processor Topology else - ! Initial estimate of optimal processor topology num_procs_x = 1 num_procs_y = num_procs @@ -1320,7 +1316,6 @@ contains ! 1D Cartesian Processor Topology else - ! Optimal processor topology num_procs_x = num_procs @@ -1428,20 +1423,17 @@ contains call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(-buff_size), buff_size, mpi_p, & & bc_x%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only - ! Send/receive buffer to/from bc_x%beg/bc_x%beg call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(-buff_size), buff_size, mpi_p, bc_x%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end - if (bc_x%beg >= 0) then ! PBC at the end and beginning ! Send/receive buffer to/from bc_x%beg/bc_x%end call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(m + 1), buff_size, mpi_p, bc_x%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only - ! Send/receive buffer to/from bc_x%end/bc_x%end call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(m + 1), buff_size, mpi_p, & & bc_x%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) @@ -1459,20 +1451,17 @@ contains call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(-buff_size), buff_size, mpi_p, & & bc_y%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only - ! Send/receive buffer to/from bc_y%beg/bc_y%beg call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(-buff_size), buff_size, mpi_p, bc_y%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end - if (bc_y%beg >= 0) then ! PBC at the end and beginning ! Send/receive buffer to/from bc_y%beg/bc_y%end call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(n + 1), buff_size, mpi_p, bc_y%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only - ! Send/receive buffer to/from bc_y%end/bc_y%end call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(n + 1), buff_size, mpi_p, & & bc_y%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) @@ -1482,7 +1471,6 @@ contains ! MPI Communication in z-direction else - if (pbc_loc == -1) then ! PBC at the beginning if (bc_z%end >= 0) then ! PBC at the beginning and end @@ -1491,20 +1479,17 @@ contains call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(-buff_size), buff_size, mpi_p, & & bc_z%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only - ! Send/receive buffer to/from bc_z%beg/bc_z%beg call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(-buff_size), buff_size, mpi_p, bc_z%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end - if (bc_z%beg >= 0) then ! PBC at the end and beginning ! Send/receive buffer to/from bc_z%beg/bc_z%end call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(p + 1), buff_size, mpi_p, bc_z%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only - ! Send/receive buffer to/from bc_z%end/bc_z%end call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(p + 1), buff_size, mpi_p, & & bc_z%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index e76d815fc4..179910c91a 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -203,7 +203,6 @@ contains ! correcting the vapor partial density q_cons_vf(vp + contxb - 1)%sf(j, k, l) = mixM*rM else - ! returning partial pressures to what they were from the homogeneous solver liquid q_cons_vf(lp + contxb - 1)%sf(j, k, l) = m1 @@ -604,7 +603,6 @@ contains ! assigning Saturation temperature TSat = 0.0_wp else - ! calculating initial estimate for temperature in the TSat procedure. I will also use this variable to iterate over the ! Newton's solver TSat = TSIn diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 7746c22c45..9c7081ec5d 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -152,7 +152,6 @@ contains pres = (energy - 0.5_wp*(mom**2._wp)/rho - pi_inf - qv - E_e)/gamma end if #:else - Y_rs(:) = rhoYks(:)/rho e_Per_Kg = energy/rho Pdyn_Per_Kg = dyn_p/rho @@ -418,7 +417,6 @@ contains ! Simulation is 2D else - allocate (rho_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) allocate (gamma_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) allocate (pi_inf_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) @@ -427,7 +425,6 @@ contains ! Simulation is 1D else - allocate (rho_sf(-buff_size:m + buff_size, 0:0, 0:0)) allocate (gamma_sf(-buff_size:m + buff_size, 0:0, 0:0)) allocate (pi_inf_sf(-buff_size:m + buff_size, 0:0, 0:0)) diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 623af38e11..cfe4115b0c 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -204,7 +204,6 @@ contains ! Generating Binary Directory Tree else - ! Creating the directory associated with the local process dbdir = trim(case_dir) // '/binary' @@ -451,7 +450,6 @@ contains ! Binary Database Format else - ! Generating the relative path to the formatted database slave file, that is to be opened for the current time-step, ! t_step write (file_loc, '(A,I0,A)') '/', t_step, '.dat' @@ -645,7 +643,6 @@ contains ! One-dimensional local grid data is written to the formatted database slave file. In addition, the local grid data ! is put together by the root process and written to the master file. else - if (precision == 1) then write (dbfile) real(x_cb, sp) else @@ -805,7 +802,6 @@ contains ! Binary Database Format else - ! Writing the name of the flow variable and its data, associated with the local processor, to the formatted database ! slave file if (precision == 1) then diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index e6041a954b..f34b0f2c06 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -892,7 +892,6 @@ contains ! Allocating the grid variables, only used for the 1D simulations, and containing the defragmented computational domain ! grid data else - allocate (x_root_cb(-1:m_root)) allocate (x_root_cc(0:m_root)) diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index e96109bb61..947114793a 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -217,7 +217,6 @@ contains call MPI_GATHERV(maxval(y_cb), 1, mpi_p, spatial_extents(4, 0), recvcounts, 4*displs, mpi_p, 0, MPI_COMM_WORLD, ierr) ! Simulation is 1D else - ! For 1D, recvcounts/displs are sized for grid defragmentation (m+1 per rank), not for scalar gathers. Use MPI_GATHER ! instead. @@ -246,7 +245,6 @@ contains ! Binary database format else - call MPI_GATHERV(x_cb(0), m + 1, mpi_p, x_root_cb(0), recvcounts, displs, mpi_p, 0, MPI_COMM_WORLD, ierr) if (proc_rank == 0) x_root_cb(-1) = x_cb(-1) diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index 59f3479e37..b0b673a579 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -85,7 +85,6 @@ impure subroutine s_generate_serial_grid y_cb(i - 1) = y_domain%beg + dy*real(2*i - 1, wp) end do else - dy = (y_domain%end - y_domain%beg)/real(n + 1, wp) do i = 0, n diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 9b05178a98..3e1f516424 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -145,7 +145,6 @@ contains ! 1D Patch Geometries else - do i = 1, num_patches if (proc_rank == 0) then print *, 'Processing patch', i diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index a119f60bb6..925ee63639 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -586,7 +586,6 @@ contains gas_p(k, 1) = myPb gas_mv(k, 1) = myMass_v else - ! Radial acceleration from bubble models intfc_dveldt(k, stage) = f_rddot(myRho, myPinf, myR, myV, myR0, myPb, myPbdot, dmalf, dmntait, dmBtait, & & dm_bub_adv_src, dm_divu, myCson) diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index f7a9aa27c8..2e05234a62 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -230,7 +230,6 @@ contains & **(3._wp*(strength_idx + 1._wp)) end do else - !> 2D cartesian function: ! We smear particles considering a virtual depth (lag_params%charwidth) theta = 0._wp diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 9abd7b526b..a7a3ad3210 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -398,7 +398,6 @@ contains ! Computing CBC4 Coefficients else - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp fd_coef_${XYZ}$ (0, & & cbc_loc_in) = -50._wp/(25._wp*ds(0) + 2._wp*ds(1) - 1.e1_wp*ds(2) + 1.e1_wp*ds(3) & @@ -479,7 +478,6 @@ contains ! Associating CBC Coefficients in z-direction else - ! fd_coef => fd_coef_z; if (weno_order > 1) pi_coef => pi_coef_z if (cbc_loc_in == -1) then @@ -948,7 +946,6 @@ contains & i) + ds(0)*dadv_dt(i - E_idx)) end do else - $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf_l(-1, k, r, i) = flux_rs${XYZ}$_vf_l(0, k, r, i) + ds(0)*dadv_dt(i - E_idx) @@ -1158,7 +1155,6 @@ contains ! Reshaping Inputted Data in z-direction else - $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, sys_size do r = is3%beg, is3%end @@ -1349,7 +1345,6 @@ contains ! Reshaping Outputted Data in z-direction else - $:GPU_PARALLEL_LOOP(private='[i, j, k, r]', collapse=4) do i = 1, flux_cbc_index do r = is3%beg, is3%end diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 02dd4d33d3..339fedd220 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -74,7 +74,6 @@ contains #if defined(MFC_GPU) rank = 1; istride = 1; ostride = 1 - allocate (gpu_fft_size(1:rank), iembed(1:rank), oembed(1:rank)) gpu_fft_size(1) = real_size; diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 3a4d0af917..2c25af959f 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -905,7 +905,6 @@ contains ! Volume Fraction Model else - ! Annotating structure of the state and flux vectors belonging to the system of equations defined by the selected number ! of spatial dimensions and the volume fraction model if (model_eqns == 2) then diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 86c155c81a..74ec1d73eb 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -698,7 +698,6 @@ contains interp_coeffs(:,:, 1) = eta(:,:, 1)/buf end if else - if (ib_markers%sf(i, j, k + 1) /= 0) alpha(1, 1, 2) = 0._wp if (ib_markers%sf(i + 1, j, k + 1) /= 0) alpha(2, 1, 2) = 0._wp if (ib_markers%sf(i, j + 1, k + 1) /= 0) alpha(1, 2, 2) = 0._wp diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index fe92276655..c823af51c8 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -1449,7 +1449,6 @@ contains $:END_GPU_PARALLEL_LOOP() end if else if (idir == 2) then ! y-direction - if (surface_tension) then $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p @@ -1504,7 +1503,6 @@ contains end do $:END_GPU_PARALLEL_LOOP() else - if ((surface_tension .or. viscous) .or. chem_params%diffusion) then $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) do l = 0, p @@ -1567,7 +1565,6 @@ contains $:END_GPU_PARALLEL_LOOP() end if else - $:GPU_PARALLEL_LOOP(private='[i, j, k, l]', collapse=3) do l = 0, p do k = 0, n @@ -1584,7 +1581,6 @@ contains end if end if else if (idir == 3) then ! z-direction - if (surface_tension) then $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p @@ -1695,7 +1691,6 @@ contains & recon_dir, is1, is2, is3) end if else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1, is2, is3) end if diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index c6f992b62a..a4e8044773 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2624,7 +2624,6 @@ contains R3V2Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 3) R3V2Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 3) else - PbwR3Lbar = 0._wp PbwR3Rbar = 0._wp @@ -3940,7 +3939,6 @@ contains ! 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 @@ -4137,7 +4135,6 @@ contains ! Reshaping Inputted Data in z-direction else - if (viscous .or. (surface_tension) .or. dummy) then $:GPU_PARALLEL_LOOP(collapse=4) do i = momxb, E_idx diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index a45f883bbe..51cd3764c6 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -531,7 +531,6 @@ contains if (ib) then call s_initialize_mpi_data(q_cons_vf, ib_markers) else - call s_initialize_mpi_data(q_cons_vf) end if diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 42c84da9bf..2e9c1e5839 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -544,7 +544,6 @@ contains end if end do else ! Compute velocity gradient at cell centers using finite differences - iv%beg = mom_idx%beg; iv%end = mom_idx%end $:GPU_UPDATE(device='[iv]') @@ -854,14 +853,12 @@ contains end do #:endif else - do i = iv%beg, iv%end call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dy_qp(1)%vf(i), & & dq_prim_dy_qp(1)%vf(i)) end do end if else - do i = iv%beg, iv%end call s_compute_fd_gradient(q_prim_qp%vf(i), dq_prim_dx_qp(1)%vf(i), dq_prim_dx_qp(1)%vf(i), & & dq_prim_dx_qp(1)%vf(i)) @@ -1011,7 +1008,6 @@ contains & recon_dir, is1_viscous, is2_viscous, is3_viscous) end if else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & & is3_viscous) @@ -1144,7 +1140,6 @@ contains ! First-Order Spatial Derivatives in z-direction else - ! A general application of the scalar divergence theorem that utilizes the left and right cell-boundary ! integral-averages, inside each cell, or an arithmetic mean of these two at the cell-boundaries, to calculate the ! cell-averaged first-order spatial derivatives inside the cell. diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 71d13e305b..450d49ec0e 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -360,7 +360,6 @@ contains end if end if else ! WENO7 - if (.not. teno) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn ! Reference: Shu (1997) "Essentially Non-Oscillatory and Weighted Essentially Non-Oscillatory Schemes From 83576b6d603a3a0cb12895f9526653d93dc151cd Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 17:30:13 -0400 Subject: [PATCH 08/25] Apply ffmt: strip trailing !& no-op comments from m_weno.fpp --- src/simulation/m_weno.fpp | 154 ++++++++++++++++++-------------------- 1 file changed, 74 insertions(+), 80 deletions(-) diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 450d49ec0e..aae0d4e460 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -377,141 +377,141 @@ contains w = s_cb(i - 3:i + 4) - s_cb(i) ! Offset using s_cb(i) to reduce floating point error d_cbR_${XYZ}$ (0, & & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & - & *(w(1) - w(8))) !& + & *(w(1) - w(8))) d_cbR_${XYZ}$ (1, & & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1) & & *w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7) & & *w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7)) & - & *(w(2) - w(8))) !& + & *(w(2) - w(8))) d_cbR_${XYZ}$ (2, & & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2) & & *w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7) & & *w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8)) & - & *(w(3) - w(8))) !& + & *(w(3) - w(8))) d_cbR_${XYZ}$ (3, & & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8)) & - & *(w(3) - w(8))) !& + & *(w(3) - w(8))) w = s_cb(i + 4:i - 3:-1) - s_cb(i) d_cbL_${XYZ}$ (0, & & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(3) - w(5)))/((w(1) - w(8))*(w(2) - w(8)) & - & *(w(3) - w(8))) !& + & *(w(3) - w(8))) d_cbL_${XYZ}$ (1, & & i + 1) = ((w(1) - w(5))*(w(2) - w(5))*(w(5) - w(8))*(w(1)*w(2) + w(1)*w(3) + w(2) & & *w(3) - w(1)*w(7) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) - w(3)*w(7) - w(3)*w(8) + w(7) & & *w(8) + w(7)**2 + w(8)**2))/((w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7))*(w(2) - w(8)) & - & *(w(3) - w(8))) !& + & *(w(3) - w(8))) d_cbL_${XYZ}$ (2, & & i + 1) = ((w(1) - w(5))*(w(5) - w(7))*(w(5) - w(8))*(w(1)*w(2) - w(1)*w(6) - w(1) & & *w(7) - w(2)*w(6) - w(1)*w(8) - w(2)*w(7) - w(2)*w(8) + w(6)*w(7) + w(6)*w(8) + w(7) & & *w(8) + w(1)**2 + w(2)**2))/((w(1) - w(6))*(w(1) - w(7))*(w(1) - w(8))*(w(2) - w(7)) & - & *(w(2) - w(8))) !& + & *(w(2) - w(8))) d_cbL_${XYZ}$ (3, & & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & - & *(w(1) - w(8))) !& + & *(w(1) - w(8))) ! Note: Left has the reversed order of both points and coefficients compared to the right y = s_cb(i + 1:i + 4) - s_cb(i:i + 3) poly_coef_cbR_${XYZ}$ (i + 1, 0, & & 0) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & + y(2) + y(3) + y(4))) poly_coef_cbR_${XYZ}$ (i + 1, 0, & & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) & & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & - & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbR_${XYZ}$ (i + 1, 0, & & 2) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & & + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) & - & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) y = s_cb(i:i + 3) - s_cb(i - 1:i + 2) poly_coef_cbR_${XYZ}$ (i + 1, 1, & & 0) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & + y(2) + y(3) + y(4))) poly_coef_cbR_${XYZ}$ (i + 1, 1, & & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) & & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & - & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbR_${XYZ}$ (i + 1, 1, & & 2) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & + y(2) + y(3) + y(4))) y = s_cb(i - 1:i + 2) - s_cb(i - 2:i + 1) poly_coef_cbR_${XYZ}$ (i + 1, 2, & & 0) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbR_${XYZ}$ (i + 1, 2, & & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & & + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) & - & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbR_${XYZ}$ (i + 1, 2, & & 2) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & + y(2) + y(3) + y(4))) y = s_cb(i - 2:i + 1) - s_cb(i - 3:i) poly_coef_cbR_${XYZ}$ (i + 1, 3, & & 0) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 & & + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) & - & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbR_${XYZ}$ (i + 1, 3, & & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) & & + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2)) & & /((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))) !& + & + y(4))) poly_coef_cbR_${XYZ}$ (i + 1, 3, & & 2) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) & - & + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(3))*(y(1) + y(2) + y(3) + y(4))) y = s_cb(i + 1:i - 2:-1) - s_cb(i:i - 3:-1) poly_coef_cbL_${XYZ}$ (i + 1, 3, & & 2) = (y(1)*y(2)*(y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & + y(2) + y(3) + y(4))) poly_coef_cbL_${XYZ}$ (i + 1, 3, & & 1) = -(y(1)*y(2)*(3*y(2)**2 + 6*y(2)*y(3) + 3*y(2)*y(4) + 2*y(1)*y(2) & & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & - & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbL_${XYZ}$ (i + 1, 3, & & 0) = (y(1)*(y(1)**2 + 3*y(1)*y(2) + 2*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & & + 4*y(2)*y(3) + 2*y(4)*y(2) + y(3)**2 + y(4)*y(3)))/((y(1) + y(2))*(y(1) & - & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(2) + y(3))*(y(1) + y(2) + y(3) + y(4))) y = s_cb(i + 2:i - 1:-1) - s_cb(i + 1:i - 2:-1) poly_coef_cbL_${XYZ}$ (i + 1, 2, & & 2) = -(y(2)*y(3)*(y(1) + y(2)))/((y(3) + y(4))*(y(2) + y(3) + y(4))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & + y(2) + y(3) + y(4))) poly_coef_cbL_${XYZ}$ (i + 1, 2, & & 1) = (y(2)*(y(1) + y(2))*(y(2)**2 + 4*y(2)*y(3) + 2*y(2)*y(4) + y(1)*y(2) & & + 3*y(3)**2 + 3*y(3)*y(4) + 2*y(1)*y(3) + y(4)**2 + y(1)*y(4)))/((y(2) + y(3) & - & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & )*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbL_${XYZ}$ (i + 1, 2, & & 0) = (y(2)*y(3)*(y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & + y(2) + y(3) + y(4))) y = s_cb(i + 3:i:-1) - s_cb(i + 2:i - 1:-1) poly_coef_cbL_${XYZ}$ (i + 1, 1, & & 2) = (y(3)*(y(2) + y(3))*(y(1) + y(2) + y(3)))/((y(3) + y(4))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbL_${XYZ}$ (i + 1, 1, & & 1) = (y(3)*y(4)*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + y(4)*y(1) + 3*y(2)**2 & & + 6*y(2)*y(3) + 2*y(4)*y(2) + 3*y(3)**2 + 2*y(4)*y(3)))/((y(2) + y(3))*(y(1) & - & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbL_${XYZ}$ (i + 1, 1, & & 0) = -(y(3)*y(4)*(y(2) + y(3)))/((y(1) + y(2))*(y(1) + y(2) + y(3))*(y(1) & - & + y(2) + y(3) + y(4))) !& + & + y(2) + y(3) + y(4))) y = s_cb(i + 4:i + 1:-1) - s_cb(i + 3:i:-1) poly_coef_cbL_${XYZ}$ (i + 1, 0, & & 2) = (y(4)*(y(2)**2 + 4*y(2)*y(3) + 4*y(2)*y(4) + y(1)*y(2) + 3*y(3)**2 & & + 6*y(3)*y(4) + 2*y(1)*y(3) + 3*y(4)**2 + 2*y(1)*y(4)))/((y(3) + y(4))*(y(2) & - & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbL_${XYZ}$ (i + 1, 0, & & 1) = -(y(4)*(y(3) + y(4))*(y(1)**2 + 3*y(1)*y(2) + 3*y(1)*y(3) + 2*y(1)*y(4) & & + 3*y(2)**2 + 6*y(2)*y(3) + 4*y(2)*y(4) + 3*y(3)**2 + 4*y(3)*y(4) + y(4)**2)) & & /((y(2) + y(3))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))) !& + & + y(4))) poly_coef_cbL_${XYZ}$ (i + 1, 0, & & 0) = (y(4)*(y(3) + y(4))*(y(2) + y(3) + y(4)))/((y(1) + y(2))*(y(1) + y(2) & - & + y(3))*(y(1) + y(2) + y(3) + y(4))) !& + & + y(3))*(y(1) + y(2) + y(3) + y(4))) poly_coef_cbL_${XYZ}$ (i + 1,:,:) = -poly_coef_cbL_${XYZ}$ (i + 1,:,:) ! Note: negative sign as the direction of taking the difference (dvd) is reversed @@ -527,7 +527,7 @@ contains & + 260*y(2)**2*y(4)**2 + 120*y(2)*y(3)**3 + 270*y(2)*y(3)**2*y(4) + 800*y(2)*y(3) & & *y(4)**2 + 450*y(2)*y(4)**3 + 45*y(3)**4 + 135*y(3)**3*y(4) + 600*y(3)**2*y(4) & & **2 + 675*y(3)*y(4)**3 + 996*y(4)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4)) & - & **2*(y(1) + y(2) + y(3) + y(4))**2) !& + & **2*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 3, & & 1) = -(4*y(4)**2*(10*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2)*y(4) + 20*y(1)**3*y(3) & & **2 + 25*y(1)**3*y(3)*y(4) + 105*y(1)**3*y(4)**2 + 40*y(1)**2*y(2)**2*y(3) & @@ -544,7 +544,7 @@ contains & *y(3)**3*y(4) + 4000*y(2)*y(3)**2*y(4)**2 + 4010*y(2)*y(3)*y(4)**3 + 4154*y(2) & & *y(4)**4 + 90*y(3)**5 + 270*y(3)**4*y(4) + 1800*y(3)**3*y(4)**2 + 2655*y(3) & & **2*y(4)**3 + 4464*y(3)*y(4)**4 + 1767*y(4)**5))/(5*(y(2) + y(3))*(y(3) + y(4)) & - & *(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & *(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 3, & & 2) = (4*y(4)**2*(10*y(2)**3*y(3) + 5*y(2)**3*y(4) + 50*y(2)**2*y(3)**2 + 60*y(2) & & **2*y(3)*y(4) + 10*y(1)*y(2)**2*y(3) + 215*y(2)**2*y(4)**2 + 5*y(1)*y(2)**2*y(4) & @@ -553,7 +553,7 @@ contains & + 30*y(3)**4 + 75*y(3)**3*y(4) + 20*y(1)*y(3)**3 + 665*y(3)**2*y(4)**2 + 35*y(1) & & *y(3)**2*y(4) + 725*y(3)*y(4)**3 + 220*y(1)*y(3)*y(4)**2 + 1767*y(4)**4 & & + 105*y(1)*y(4)**3))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & - & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 3, & & 3) = (4*y(4)**2*(5*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 50*y(1)**4*y(4)**2 & & + 30*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 300*y(1)**3*y(2)*y(4)**2 & @@ -577,7 +577,7 @@ contains & + 3524*y(2)*y(4)**5 + 45*y(3)**6 + 135*y(3)**5*y(4) + 1395*y(3)**4*y(4)**2 & & + 2565*y(3)**3*y(4)**3 + 4884*y(3)**2*y(4)**4 + 3624*y(3)*y(4)**5 + 831*y(4)**6)) & & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 3, & & 4) = -(4*y(4)**2*(10*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 100*y(1) & & **2*y(2)*y(4)**2 + 10*y(1)**2*y(3)**3 + 15*y(1)**2*y(3)**2*y(4) + 205*y(1) & @@ -591,13 +591,13 @@ contains & + 2205*y(2)*y(3)**2*y(4)**2 + 2115*y(2)*y(3)*y(4)**3 + 3624*y(2)*y(4)**4 & & + 30*y(3)**5 + 75*y(3)**4*y(4) + 1060*y(3)**3*y(4)**2 + 1515*y(3)**2*y(4)**3 & & + 3824*y(3)*y(4)**4 + 1662*y(4)**5))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) & - & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 3, & & 5) = (4*y(4)**2*(5*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 & & + 10*y(2)*y(3)**3 + 15*y(2)*y(3)**2*y(4) + 205*y(2)*y(3)*y(4)**2 + 100*y(2)*y(4) & & **3 + 5*y(3)**4 + 10*y(3)**3*y(4) + 205*y(3)**2*y(4)**2 + 200*y(3)*y(4)**3 & & + 831*y(4)**4))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & + y(4))**2) y = s_cb(i - 1:i + 2) - s_cb(i - 2:i + 1) beta_coef_${XYZ}$ (i + 1, 2, & @@ -605,7 +605,7 @@ contains & + 10*y(1)*y(2)**3 + 15*y(1)*y(2)**2*y(3) + 205*y(1)*y(2)*y(3)**2 + 100*y(1)*y(3) & & **3 + 5*y(2)**4 + 10*y(2)**3*y(3) + 205*y(2)**2*y(3)**2 + 200*y(2)*y(3)**3 & & + 831*y(3)**4))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & + y(4))**2) beta_coef_${XYZ}$ (i + 1, 2, & & 1) = (4*y(3)**2*(5*y(1)**3*y(2)*y(3) + 10*y(1)**3*y(2)*y(4) - 95*y(1)**3*y(3)**2 & & + 5*y(1)**3*y(3)*y(4) + 20*y(1)**2*y(2)**2*y(3) + 40*y(1)**2*y(2)**2*y(4) & @@ -620,14 +620,14 @@ contains & - 3694*y(2)*y(3)**4 + 250*y(2)*y(3)**3*y(4) + 220*y(2)*y(3)**2*y(4)**2 & & - 3219*y(3)**5 - 1452*y(3)**4*y(4) + 105*y(3)**3*y(4)**2))/(5*(y(2) + y(3))*(y(3) & & + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4)) & - & **2) !& + & **2) beta_coef_${XYZ}$ (i + 1, 2, & & 2) = -(4*y(3)**2*(5*y(2)**3*y(3) - 95*y(2)*y(3)**3 - 190*y(2)**2*y(3)**2 & & + 10*y(2)**3*y(4) + 100*y(3)**3*y(4) - 1562*y(3)**4 - 95*y(1)*y(2)*y(3)**2 & & + 5*y(1)*y(2)**2*y(3) + 10*y(1)*y(2)**2*y(4) + 100*y(1)*y(3)**2*y(4) + 205*y(2) & & *y(3)**2*y(4) + 15*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2)) & & *(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & + y(4))**2) beta_coef_${XYZ}$ (i + 1, 2, & & 3) = (4*y(3)**2*(50*y(1)**4*y(3)**2 + 5*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 & & + 300*y(1)**3*y(2)*y(3)**2 + 30*y(1)**3*y(2)*y(3)*y(4) + 30*y(1)**3*y(2)*y(4)**2 & @@ -650,7 +650,7 @@ contains & + 140*y(2)*y(3)**2*y(4)**3 + 30*y(2)*y(3)*y(4)**4 + 3174*y(3)**6 + 3039*y(3) & & **5*y(4) + 771*y(3)**4*y(4)**2 + 135*y(3)**3*y(4)**3 + 60*y(3)**2*y(4)**4)) & & /(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 2, & & 4) = -(4*y(3)**2*(100*y(1)**2*y(2)*y(3)**2 + 10*y(1)**2*y(2)*y(3)*y(4) + 10*y(1) & & **2*y(2)*y(4)**2 - 95*y(1)**2*y(3)**2*y(4) + 5*y(1)**2*y(3)*y(4)**2 + 300*y(1) & @@ -663,17 +663,17 @@ contains & - 35*y(2)*y(3)**2*y(4)**2 + 25*y(2)*y(3)*y(4)**3 + 3124*y(3)**5 + 1467*y(3) & & **4*y(4) + 110*y(3)**3*y(4)**2 + 105*y(3)**2*y(4)**3))/(5*(y(1) + y(2))*(y(2) & & + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4)) & - & **2) !& + & **2) beta_coef_${XYZ}$ (i + 1, 2, & & 5) = (4*y(3)**2*(50*y(2)**2*y(3)**2 + 5*y(2)**2*y(3)*y(4) + 5*y(2)**2*y(4)**2 & & - 95*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 781*y(3)**4 + 50*y(3)**2*y(4)**2)) & - & /(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & /(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) + y(3) + y(4))**2) y = s_cb(i:i + 3) - s_cb(i - 1:i + 2) beta_coef_${XYZ}$ (i + 1, 1, & & 0) = (4*y(2)**2*(50*y(1)**2*y(2)**2 + 5*y(1)**2*y(2)*y(3) + 5*y(1)**2*y(3)**2 & & - 95*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 781*y(2)**4 + 50*y(2)**2*y(3)**2)) & - & /(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & /(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 1, & & 1) = -(4*y(2)**2*(105*y(1)**3*y(2)**2 + 25*y(1)**3*y(2)*y(3) + 5*y(1)**3*y(2) & & *y(4) + 20*y(1)**3*y(3)**2 + 10*y(1)**3*y(3)*y(4) + 110*y(1)**2*y(2)**3 - 35*y(1) & @@ -686,14 +686,14 @@ contains & + 1562*y(2)**4*y(4) + 400*y(2)**3*y(3)**2 + 200*y(2)**3*y(3)*y(4) + 300*y(2) & & **2*y(3)**3 + 300*y(2)**2*y(3)**2*y(4) + 100*y(2)**2*y(3)*y(4)**2))/(5*(y(2) & & + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 1, & & 2) = -(4*y(2)**2*(100*y(1)*y(2)**3 - 190*y(2)**2*y(3)**2 + 10*y(1)*y(3)**3 & & + 5*y(2)*y(3)**3 - 95*y(2)**3*y(3) - 1562*y(2)**4 + 15*y(1)*y(2)*y(3)**2 & & + 205*y(1)*y(2)**2*y(3) + 100*y(1)*y(2)**2*y(4) + 10*y(1)*y(3)**2*y(4) + 5*y(2) & & *y(3)**2*y(4) - 95*y(2)**2*y(3)*y(4) + 10*y(1)*y(2)*y(3)*y(4)))/(5*(y(1) + y(2)) & & *(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & + y(4))**2) beta_coef_${XYZ}$ (i + 1, 1, & & 3) = (4*y(2)**2*(60*y(1)**4*y(2)**2 + 30*y(1)**4*y(2)*y(3) + 15*y(1)**4*y(2)*y(4) & & + 20*y(1)**4*y(3)**2 + 20*y(1)**4*y(3)*y(4) + 5*y(1)**4*y(4)**2 + 135*y(1) & @@ -715,7 +715,7 @@ contains & **3 + 1800*y(2)**3*y(3)**2*y(4) + 1000*y(2)**3*y(3)*y(4)**2 + 200*y(2)**3*y(4) & & **3 + 450*y(2)**2*y(3)**4 + 900*y(2)**2*y(3)**3*y(4) + 750*y(2)**2*y(3)**2*y(4) & & **2 + 300*y(2)**2*y(3)*y(4)**3 + 50*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) & - & + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & + y(2) + y(3))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 1, & & 4) = (4*y(2)**2*(105*y(1)**2*y(2)**3 + 220*y(1)**2*y(2)**2*y(3) + 110*y(1) & & **2*y(2)**2*y(4) + 35*y(1)**2*y(2)*y(3)**2 + 35*y(1)**2*y(2)*y(3)*y(4) + 5*y(1) & @@ -729,13 +729,13 @@ contains & - 550*y(2)**2*y(3)**3 - 825*y(2)**2*y(3)**2*y(4) - 465*y(2)**2*y(3)*y(4)**2 & & - 95*y(2)**2*y(4)**3 + 15*y(2)*y(3)**4 + 30*y(2)*y(3)**3*y(4) + 20*y(2)*y(3) & & **2*y(4)**2 + 5*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2))*(y(2) + y(3))*(y(1) + y(2) & - & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 1, & & 5) = (4*y(2)**2*(831*y(2)**4 + 200*y(2)**3*y(3) + 100*y(2)**3*y(4) + 205*y(2) & & **2*y(3)**2 + 205*y(2)**2*y(3)*y(4) + 50*y(2)**2*y(4)**2 + 10*y(2)*y(3)**3 & & + 15*y(2)*y(3)**2*y(4) + 5*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) & & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & + y(3) + y(4))**2) y = s_cb(i + 1:i + 4) - s_cb(i:i + 3) beta_coef_${XYZ}$ (i + 1, 0, & @@ -743,7 +743,7 @@ contains & **2*y(2)**2 + 205*y(1)**2*y(2)*y(3) + 50*y(1)**2*y(3)**2 + 10*y(1)*y(2)**3 & & + 15*y(1)*y(2)**2*y(3) + 5*y(1)*y(2)*y(3)**2 + 5*y(2)**4 + 10*y(2)**3*y(3) & & + 5*y(2)**2*y(3)**2))/(5*(y(3) + y(4))**2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 0, & & 1) = -(4*y(1)**2*(1662*y(1)**5 + 3824*y(1)**4*y(2) + 3624*y(1)**4*y(3) & & + 1762*y(1)**4*y(4) + 1515*y(1)**3*y(2)**2 + 2115*y(1)**3*y(2)*y(3) + 805*y(1) & @@ -757,7 +757,7 @@ contains & + 90*y(2)**4*y(3) + 30*y(2)**4*y(4) + 90*y(2)**3*y(3)**2 + 60*y(2)**3*y(3)*y(4) & & + 10*y(2)**3*y(4)**2 + 30*y(2)**2*y(3)**3 + 30*y(2)**2*y(3)**2*y(4) + 10*y(2) & & **2*y(3)*y(4)**2))/(5*(y(2) + y(3))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) & - & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 0, & & 2) = (4*y(1)**2*(1767*y(1)**4 + 725*y(1)**3*y(2) + 415*y(1)**3*y(3) + 105*y(4) & & *y(1)**3 + 665*y(1)**2*y(2)**2 + 775*y(1)**2*y(2)*y(3) + 220*y(4)*y(1)**2*y(2) & @@ -766,7 +766,7 @@ contains & + 5*y(1)*y(3)**3 + 5*y(4)*y(1)*y(3)**2 + 30*y(2)**4 + 70*y(2)**3*y(3) + 20*y(4) & & *y(2)**3 + 50*y(2)**2*y(3)**2 + 30*y(4)*y(2)**2*y(3) + 10*y(2)*y(3)**3 + 10*y(4) & & *y(2)*y(3)**2))/(5*(y(1) + y(2))*(y(3) + y(4))*(y(1) + y(2) + y(3))*(y(2) + y(3) & - & + y(4))*(y(1) + y(2) + y(3) + y(4))**2) !& + & + y(4))*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 0, & & 3) = (4*y(1)**2*(831*y(1)**6 + 3624*y(1)**5*y(2) + 3524*y(1)**5*y(3) + 1762*y(1) & & **5*y(4) + 4884*y(1)**4*y(2)**2 + 9058*y(1)**4*y(2)*y(3) + 4529*y(1)**4*y(2)*y(4) & @@ -790,7 +790,7 @@ contains & **3*y(3)**2*y(4) + 150*y(2)**3*y(3)*y(4)**2 + 30*y(2)**3*y(4)**3 + 45*y(2) & & **2*y(3)**4 + 90*y(2)**2*y(3)**3*y(4) + 75*y(2)**2*y(3)**2*y(4)**2 + 30*y(2) & & **2*y(3)*y(4)**3 + 5*y(2)**2*y(4)**4))/(5*(y(2) + y(3))**2*(y(1) + y(2) + y(3)) & - & **2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) !& + & **2*(y(2) + y(3) + y(4))**2*(y(1) + y(2) + y(3) + y(4))**2) beta_coef_${XYZ}$ (i + 1, 0, & & 4) = -(4*y(1)**2*(1767*y(1)**5 + 4464*y(1)**4*y(2) + 4154*y(1)**4*y(3) & & + 2077*y(1)**4*y(4) + 2655*y(1)**3*y(2)**2 + 4010*y(1)**3*y(2)*y(3) + 2005*y(1) & @@ -808,7 +808,7 @@ contains & + 130*y(2)**2*y(3)*y(4)**2 + 20*y(2)**2*y(4)**3 + 30*y(2)*y(3)**4 + 60*y(2)*y(3) & & **3*y(4) + 40*y(2)*y(3)**2*y(4)**2 + 10*y(2)*y(3)*y(4)**3))/(5*(y(1) + y(2)) & & *(y(2) + y(3))*(y(1) + y(2) + y(3))**2*(y(2) + y(3) + y(4))*(y(1) + y(2) + y(3) & - & + y(4))**2) !& + & + y(4))**2) beta_coef_${XYZ}$ (i + 1, 0, & & 5) = (4*y(1)**2*(996*y(1)**4 + 675*y(1)**3*y(2) + 450*y(1)**3*y(3) + 225*y(1) & & **3*y(4) + 600*y(1)**2*y(2)**2 + 800*y(1)**2*y(2)*y(3) + 400*y(1)**2*y(2)*y(4) & @@ -819,7 +819,7 @@ contains & + 110*y(2)**2*y(3)**2 + 110*y(2)**2*y(3)*y(4) + 20*y(2)**2*y(4)**2 + 40*y(2)*y(3) & & **3 + 60*y(2)*y(3)**2*y(4) + 20*y(2)*y(3)*y(4)**2 + 5*y(3)**4 + 10*y(3)**3*y(4) & & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & - & + y(3) + y(4))**2) !& + & + y(3) + y(4))**2) end do else ! TENO (only supports uniform grid) ! (Fu, et al., 2016) Table 2 (for right flux) @@ -1198,11 +1198,11 @@ contains ! stencils See Figure 2 (right) for right-sided flux (at i+1/2) Here we need the ! left-sided flux, so we flip the weights with respect to the x=i point But we need ! to keep the stencil order to reuse the beta coefficients - poly(0) = (2._wp*v(-1) + 5._wp*v(0) - 1._wp*v(1))/6._wp !& - poly(1) = (11._wp*v(0) - 7._wp*v(1) + 2._wp*v(2))/6._wp !& - poly(2) = (-1._wp*v(-2) + 5._wp*v(-1) + 2._wp*v(0))/6._wp !& - poly(3) = (25._wp*v(0) - 23._wp*v(1) + 13._wp*v(2) - 3._wp*v(3))/12._wp !& - poly(4) = (1._wp*v(-3) - 5._wp*v(-2) + 13._wp*v(-1) + 3._wp*v(0))/12._wp !& + poly(0) = (2._wp*v(-1) + 5._wp*v(0) - 1._wp*v(1))/6._wp + poly(1) = (11._wp*v(0) - 7._wp*v(1) + 2._wp*v(2))/6._wp + poly(2) = (-1._wp*v(-2) + 5._wp*v(-1) + 2._wp*v(0))/6._wp + poly(3) = (25._wp*v(0) - 23._wp*v(1) + 13._wp*v(2) - 3._wp*v(3))/12._wp + poly(4) = (1._wp*v(-3) - 5._wp*v(-2) + 13._wp*v(-1) + 3._wp*v(0))/12._wp #:endif end if @@ -1235,25 +1235,19 @@ contains ! High-Order Low-Dissipation Targeted ENO Schemes for Ideal Magnetohydrodynamics (Fu ! & Tang, 2019) Section 3.2 beta(0) = 13._wp/12._wp*(v(-1) - 2._wp*v(0) + v(1))**2._wp + ((v(-1) - v(1)) & - & **2._wp)/4._wp + weno_eps !& + & **2._wp)/4._wp + weno_eps beta(1) = 13._wp/12._wp*(v(0) - 2._wp*v(1) + v(2))**2._wp + ((3._wp*v(0) & - & - 4._wp*v(1) + v(2))**2._wp)/4._wp + weno_eps !& + & - 4._wp*v(1) + v(2))**2._wp)/4._wp + weno_eps beta(2) = 13._wp/12._wp*(v(-2) - 2._wp*v(-1) + v(0))**2._wp + ((v(-2) & - & - 4._wp*v(-1) + 3._wp*v(0))**2._wp)/4._wp + weno_eps !& + & - 4._wp*v(-1) + 3._wp*v(0))**2._wp)/4._wp + weno_eps beta(3) = (v(0)*(2107._wp*v(0) - 9402._wp*v(1) + 7042._wp*v(2) - 1854._wp*v(3)) & & + v(1)*(11003._wp*v(1) - 17246._wp*v(2) + 4642._wp*v(3)) + v(2) & - & *(7043._wp*v(2) - 3882._wp*v(3)) + v(3)*(547._wp*v(3)))/240._wp + weno_eps !& - - beta(4) = ( v(-3)*(547._wp*v(-3) - 3882._wp*v(-2) + 4642._wp*v(-1) & - & - 1854._wp*v( 0)) & !& - + v(-2)*( 7043._wp*v(-2) - 17246._wp*v(-1) + 7042._wp*v( 0) & - & ) & !& - + v(-1)*( 11003._wp*v(-1) - 9402._wp*v( 0)) & - & & !& - + v( 0)*( 2107._wp*v( 0)) ) & - & / 240._wp & !& - + weno_eps !& + & *(7043._wp*v(2) - 3882._wp*v(3)) + v(3)*(547._wp*v(3)))/240._wp + weno_eps + + beta(4) = (v(-3)*(547._wp*v(-3) - 3882._wp*v(-2) + 4642._wp*v(-1) - 1854._wp*v(0)) & + & + v(-2)*(7043._wp*v(-2) - 17246._wp*v(-1) + 7042._wp*v(0)) + v(-1) & + & *(11003._wp*v(-1) - 9402._wp*v(0)) + v(0)*(2107._wp*v(0)))/240._wp + weno_eps #:endif end if @@ -1324,11 +1318,11 @@ contains & 1)*dvd(-2) + poly_coef_cbR_${XYZ}$ (j, 3, 2)*dvd(-3) else #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 - poly(0) = (-1._wp*v(-1) + 5._wp*v(0) + 2._wp*v(1))/6._wp !& - poly(1) = (2._wp*v(0) + 5._wp*v(1) - 1._wp*v(2))/6._wp !& - poly(2) = (2._wp*v(-2) - 7._wp*v(-1) + 11._wp*v(0))/6._wp !& - poly(3) = (3._wp*v(0) + 13._wp*v(1) - 5._wp*v(2) + 1._wp*v(3))/12._wp !& - poly(4) = (-3._wp*v(-3) + 13._wp*v(-2) - 23._wp*v(-1) + 25._wp*v(0))/12._wp !& + poly(0) = (-1._wp*v(-1) + 5._wp*v(0) + 2._wp*v(1))/6._wp + poly(1) = (2._wp*v(0) + 5._wp*v(1) - 1._wp*v(2))/6._wp + poly(2) = (2._wp*v(-2) - 7._wp*v(-1) + 11._wp*v(0))/6._wp + poly(3) = (3._wp*v(0) + 13._wp*v(1) - 5._wp*v(2) + 1._wp*v(3))/12._wp + poly(4) = (-3._wp*v(-3) + 13._wp*v(-2) - 23._wp*v(-1) + 25._wp*v(0))/12._wp #:endif end if From adc52192902aefeea87a02afba7eaaf76d684aaa Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 18:02:14 -0400 Subject: [PATCH 09/25] Apply ffmt: strip comment-only continuation lines (& ! ...) --- src/simulation/m_ibm.fpp | 4 ++-- src/simulation/m_rhs.fpp | 8 ++++---- src/simulation/m_time_steppers.fpp | 5 ++--- src/simulation/m_weno.fpp | 5 ++--- 4 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 74ec1d73eb..f97f696636 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -1158,8 +1158,8 @@ contains else ! we do not have an analytic moment of inertia calculation and need to approximate it directly via a sum count = 0 moment = 0._wp - cell_volume = (x_cc(1) - x_cc(0))*(y_cc(1) - y_cc(0)) & - & ! computed without grid stretching. Update in the loop to perform with stretching + cell_volume = (x_cc(1) - x_cc(0))*(y_cc(1) - y_cc(0)) + ! computed without grid stretching. Update in the loop to perform with stretching if (p /= 0) then cell_volume = cell_volume*(z_cc(1) - z_cc(0)) end if diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index c823af51c8..bfdc1686b7 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -1237,8 +1237,8 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if - case (2) & - & ! y-direction: loops q_idx (x), k_idx (y), l_idx (z); sf(q_idx, k_idx, l_idx); dy(k_idx); Kterm(q_idx,k_idx,l_idx) + case (2) + ! y-direction: loops q_idx (x), k_idx (y), l_idx (z); sf(q_idx, k_idx, l_idx); dy(k_idx); Kterm(q_idx,k_idx,l_idx) use_standard_riemann = (riemann_solver == 1 .or. riemann_solver == 4) if (use_standard_riemann) then $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & @@ -1313,8 +1313,8 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if - case (3) & - & ! z-direction: loops l_idx (x), q_idx (y), k_idx (z); sf(l_idx, q_idx, k_idx); dz(k_idx); Kterm(l_idx,q_idx,k_idx) + case (3) + ! z-direction: loops l_idx (x), q_idx (y), k_idx (z); sf(l_idx, q_idx, k_idx); dz(k_idx); Kterm(l_idx,q_idx,k_idx) if (grid_geometry == 3) then use_standard_riemann = (riemann_solver == 1) else diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 63fe4dd9b4..13d5609581 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -759,9 +759,8 @@ contains ! update the angular velocity with the torque value patch_ib(i)%angular_vel = (patch_ib(i)%angular_vel*patch_ib(i)%moment) + (rk_coef(s, & & 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum - call s_compute_moment_of_inertia(i, & - & patch_ib(i)%angular_vel) & - & ! update the moment of inertia to be based on the direction of the angular momentum + call s_compute_moment_of_inertia(i, patch_ib(i)%angular_vel) + ! update the moment of inertia to be based on the direction of the angular momentum patch_ib(i)%angular_vel = patch_ib(i)%angular_vel/patch_ib(i) & & %moment ! convert back to angular velocity with the new moment of inertia end if diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index aae0d4e460..ec29dd1718 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -1074,9 +1074,8 @@ contains tau = abs(beta(2) - beta(0)) ! Equation 25 $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - alpha(q) = d_cbL_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))) & - & ! Equation 28 (note: weno_eps was already added to beta) + alpha(q) = d_cbL_${XYZ}$ (q, j)*(1._wp + (tau/beta(q))) + ! Equation 28 (note: weno_eps was already added to beta) end do else if (teno) then ! Fu, et al. (2016) Fu''s code: https://dx.doi.org/10.13140/RG.2.2.36250.34247 From 4ab00f4fb4b021a511039bc8183debb2126ed742 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 19:41:05 -0400 Subject: [PATCH 10/25] Condense verbose multi-line comments across codebase --- src/common/include/macros.fpp | 5 +- src/common/m_helper_basic.fpp | 3 +- src/common/m_mpi_common.fpp | 4 +- src/common/m_phase_change.fpp | 7 +- src/common/m_variables_conversion.fpp | 4 +- src/post_process/m_data_output.fpp | 24 ++---- src/post_process/m_derived_variables.fpp | 24 ++---- src/post_process/m_global_parameters.fpp | 6 +- src/post_process/p_main.fpp | 4 +- src/pre_process/m_assign_variables.fpp | 9 +-- src/pre_process/m_data_output.fpp | 4 +- src/pre_process/m_global_parameters.fpp | 7 +- src/pre_process/m_icpp_patches.fpp | 93 +++++++----------------- src/pre_process/m_initial_condition.fpp | 8 +- src/pre_process/m_start_up.fpp | 15 +--- src/simulation/m_cbc.fpp | 3 +- src/simulation/m_global_parameters.fpp | 19 ++--- src/simulation/m_ib_patches.fpp | 7 +- src/simulation/m_muscl.fpp | 4 +- src/simulation/m_riemann_solvers.fpp | 3 +- src/simulation/m_start_up.fpp | 7 +- src/simulation/m_viscous.fpp | 10 +-- src/simulation/m_weno.fpp | 7 +- 23 files changed, 80 insertions(+), 197 deletions(-) diff --git a/src/common/include/macros.fpp b/src/common/include/macros.fpp index 3fc7e99cd0..3f773b3240 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -19,10 +19,7 @@ #ifdef MFC_SIMULATION #ifdef __NVCOMPILER_GPU_UNIFIED_MEM block - ! Beginning in the 25.3 release, the structure of the cudafor module has been changed slightly. The module now includes, or - ! "uses" 3 submodules: cuda_runtime_api, gpu_reductions, and sort. The cudafor functionality has not changed. But for new - ! users, or users who have needed to work-around name conflicts in the module, it may be better to use cuda_runtime_api to - ! expose interfaces to the CUDA runtime calls described in Chapter 4 of this guide. + ! NVIDIA CUDA Fortran 25.3+: uses submodules (cuda_runtime_api, gpu_reductions, sort) See ! https://docs.nvidia.com/hpc-sdk/compilers/cuda-fortran-prog-guide/index.html#fortran-host-modules #if __NVCOMPILER_MAJOR__ < 25 || (__NVCOMPILER_MAJOR__ == 25 && __NVCOMPILER_MINOR__ < 3) use cudafor, gpu_sum => sum, gpu_maxval => maxval, gpu_minval => minval diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 299f5a9c69..6f957604f6 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -125,8 +125,7 @@ contains logical, intent(in) :: igr logical, intent(in) :: ib - ! Determining the number of cells that are needed in order to store sufficient boundary conditions data as to iterate the - ! solution in the physical computational domain from one time-step iteration to the next one + ! Determine ghost cell buffer size for boundary conditions if (igr) then buff_size = (igr_order - 1)/2 + 2 diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 124a935eb8..531099cbf0 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -1046,9 +1046,7 @@ contains end do else if (cyl_coord .and. p > 0) then - ! Implement pencil processor blocking if using cylindrical coordinates so that all cells in azimuthal - ! direction are stored on a single processor. This is necessary for efficient application of Fourier filter - ! near axis. + ! Pencil blocking for cylindrical coordinates (Fourier filter near axis) ! Initial values of the processor factorization optimization num_procs_x = 1 diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index 179910c91a..6fdfa2afb1 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -144,9 +144,7 @@ contains ! case, MFL cannot be either 0 or 1, so I chose it to be 2 call s_infinite_pt_relaxation_k(j, k, l, 2, pS, p_infpT, q_cons_vf, rhoe, TS) - ! check if pTg-equilibrium is required NOTE that NOTHING else needs to be updated OTHER than the individual - ! partial densities given the outputs from the pT- and pTg-equilibrium solvers are just p and one of the partial - ! masses (pTg- case) + ! Check if pTg-equilibrium needed; only partial densities require updating if ((relax_model == 6) .and. ((q_cons_vf(lp + contxb - 1)%sf(j, k, & & l) > mixM*rM) .and. (q_cons_vf(vp + contxb - 1)%sf(j, k, & & l) > mixM*rM)) .and. (pS < pCr) .and. (TS < TCr)) then @@ -567,8 +565,7 @@ contains end if end if - ! Defining the correction in terms of an absolute value might not be the best practice. Maybe a good way to do this is to - ! partition the partial densities, giving a small percentage of the total reacting density + ! TODO: Consider partitioning partial densities instead of absolute-value correction MCT = 2*mixM ! correcting the partial densities of the reacting fluids. What to do for the nonreacting ones? diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 9c7081ec5d..f7310335a0 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -300,9 +300,7 @@ contains real(wp) :: alpha_K_sum integer :: i, j !< Generic loop iterators #ifdef MFC_SIMULATION - ! Constraining the partial densities and the volume fractions within their physical bounds to make sure that any mixture - ! variables that are derived from them result within the limits that are set by the fluids physical parameters that make up - ! the mixture + ! Constrain partial densities and volume fractions within physical bounds if (num_fluids == 1 .and. bubbles_euler) then rho_K = alpha_rho_K(1) gamma_K = gammas(1) diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index cfe4115b0c..9e8e9208ea 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -22,13 +22,10 @@ module m_data_output & s_write_energy_data_file, s_close_formatted_database_file, s_close_intf_data_file, s_close_energy_data_file, & & s_finalize_data_output_module - ! Including the Silo Fortran interface library that features the subroutines and parameters that are required to write in the - ! Silo-HDF5 database format INCLUDE 'silo.inc' + ! Include Silo-HDF5 interface library include 'silo_f9x.inc' - ! Generic storage for flow variable(s) that are to be written to formatted database file(s). Note that for 1D simulations, - ! q_root_sf is employed to gather the flow variable(s) from all sub-domains on to the root process. If the run is not parallel, - ! but serial, then q_root_sf is equal to q_sf. + ! 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 @@ -38,20 +35,15 @@ module m_data_output real(sp), allocatable, dimension(:,:,:) :: q_root_sf_s real(sp), allocatable, dimension(:,:,:) :: cyl_q_sf_s - ! The spatial and data extents array variables contain information about the minimum and maximum values of the grid and flow - ! variable(s), respectively. The purpose of bookkeeping this information is to boost the visualization of the Silo-HDF5 database - ! file(s) in VisIt. + ! Spatial and data extents for VisIt visualization real(wp), allocatable, dimension(:,:) :: spatial_extents real(wp), allocatable, dimension(:,:) :: data_extents - ! The size of the ghost zone layer at beginning of each coordinate direction (lo) and at end of each coordinate direction (hi). - ! Adding this information to Silo-HDF5 database file(s) is recommended since it supplies VisIt with connectivity information - ! between the sub-domains of a parallel data set. + ! Ghost zone layer sizes (lo/hi) for subdomain connectivity in VisIt integer, allocatable, dimension(:) :: lo_offset integer, allocatable, dimension(:) :: hi_offset - ! For Silo-HDF5 database format, this variable is used to keep track of the number of cell-boundaries, for the grid associated - ! with the local process, in each of the active coordinate directions. + ! 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 @@ -404,11 +396,7 @@ contains !> @brief Open (or create) the Silo-HDF5 or Binary formatted database slave and master files for a given time step. impure subroutine s_open_formatted_database_file(t_step) - ! Description: This subroutine opens a new formatted database file, or replaces an old one, and readies it for the data - ! storage of the grid and the flow variable(s) associated with the current time-step, t_step. This is performed by all the - ! local process(es). The root processor, in addition, must also generate a master formatted database file whose job will be - ! to link, and thus combine, the data from all of the local process(es). Note that for the Binary format, this extra task - ! that is assigned to the root process is not performed in multidimensions. + ! Open/create DB file for current time-step; rank 0 creates master file (Silo only) ! Time-step that is currently being post-processed integer, intent(in) :: t_step diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index e05364a918..e7efa5e99f 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -42,16 +42,12 @@ contains !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_derived_variables_module - ! Allocating the gradient magnitude of the density variable provided that numerical Schlieren function is outputted during - ! post-process + ! 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)) end if - ! Allocating the variables which will store the coefficients of the centered family of finite-difference schemes. Note that - ! sufficient space is allocated so that the coefficients up to any chosen order of accuracy may be bookkept. However, if - ! higher than fourth-order accuracy coefficients are wanted, the formulae required to compute these coefficients will have - ! to be implemented in the subroutine s_compute_finite_difference_coefficients. + ! Allocate FD coefficients (up to 4th order; higher orders need extension) ! Allocating centered finite-difference coefficients in x-direction if (omega_wrt(2) .or. omega_wrt(3) .or. schlieren_wrt .or. liutex_wrt) then @@ -68,8 +64,7 @@ contains allocate (fd_coeff_z(-fd_number:fd_number, -offset_z%beg:p + offset_z%end)) end if - ! Annotating the dimensionality of the dataset undergoing the post- process. A flag value of 1 indicates that the dataset is - ! 3D, while a flag value of 0 indicates that it is not. + ! Set flg=1 if 3D, else 0 if (p > 0) then flg = 1 else @@ -136,8 +131,7 @@ contains ! Fluid bulk modulus for alternate sound speed real(wp) :: blkmod1, blkmod2 - ! Computing speed of sound values from those of pressure, density, specific heat ratio function and the liquid stiffness - ! function + ! Compute speed of sound from pressure, density, gamma, liquid stiffness do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end @@ -582,17 +576,13 @@ contains end do end if - ! Up until now, only the dot product of the gradient of the density field has been calculated and stored in the gradient - ! magnitude of density variable. So now we proceed to take the square-root as to complete the desired calculation. + ! Finalize Schlieren: take sqrt of accumulated dot product gm_rho_sf = sqrt(gm_rho_sf) - ! Determining the local maximum of the gradient magnitude of density and bookkeeping the result, along with rank of the - ! local processor + ! Find local max of density gradient magnitude with processor rank gm_rho_max = (/maxval(gm_rho_sf), real(proc_rank, wp)/) - ! Comparing the local maximum gradient magnitude of the density on this processor to the those computed on the remaining - ! processors. This allows for the global maximum to be computed and the rank of the processor on which it has occurred to be - ! recorded. + ! Compute global max density gradient across all processors if (num_procs > 1) call s_mpi_reduce_maxloc(gm_rho_max) ! Computing Numerical Schlieren Function diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index f34b0f2c06..c15152c75a 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -82,8 +82,7 @@ module m_global_parameters integer :: n_start !> @} - ! NOTE: The variables m_root, x_root_cb and x_root_cc contain the grid data of the defragmented computational domain. They are - ! only used in 1D. For serial simulations, they are equal to m, x_cb and x_cc, respectively. + ! NOTE: m_root, x_root_cb, x_root_cc = defragmented grid (1D only; equals m, x_cb, x_cc in serial) !> @name Simulation Algorithm Parameters !> @{ @@ -138,8 +137,7 @@ module m_global_parameters ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). Stands for "InDices With BUFFer". type(int_bounds_info) :: idwint(1:3) - ! Cell Indices for the entire (local) domain. In simulation, this includes the buffer region. idwbuff and idwint are the same - ! otherwise. Stands for "InDices With BUFFer". + ! Cell indices (InDices With BUFFer): includes buffer in simulation only type(int_bounds_info) :: idwbuff(1:3) integer :: num_bc_patches logical :: bc_io diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index 1f8450565b..2f3c710859 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -61,9 +61,7 @@ program p_main exit end if else - ! Modifies the time-step iterator so that it may reach the final time- step to be post-processed, in the case that this - ! one is not originally attainable through constant incrementation from the first time-step. This modification is - ! performed upon reaching the final time-step. In case that it is not needed, the post-processor is done and may exit. + ! Adjust time-step iterator to reach final step if needed, else exit if ((t_step_stop - t_step) < t_step_save .and. t_step_stop /= t_step) then t_step = t_step_stop - t_step_save else if (t_step == t_step_stop) then diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index fa13d980b1..8c22bed7f5 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -66,8 +66,7 @@ contains allocate (alf_sum%sf(0:m, 0:n, 0:p)) end if - ! Depending on multicomponent flow model, the appropriate procedure for assignment of the patch mixture or species primitive - ! variables to a cell in the domain is targeted by the procedure pointer + ! Select procedure pointer based on multicomponent flow model if (model_eqns == 1) then ! Gamma/pi_inf model s_assign_patch_primitive_variables => s_assign_patch_mixture_primitive_variables @@ -258,8 +257,7 @@ contains #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - ! Density, the specific heat ratio function and the liquid stiffness function, respectively, obtained from the combination - ! of primitive variables of the current and smoothing patches + ! Density, gamma, and liquid stiffness from current and smoothing patches real(wp) :: rho !< density real(wp) :: gamma real(wp) :: lit_gamma !< specific heat ratio @@ -621,8 +619,7 @@ contains !> @brief Nullifies the patch primitive variable assignment procedure pointer. impure subroutine s_finalize_assign_variables_module - ! Nullifying procedure pointer to the subroutine assigning either the patch mixture or species primitive variables to a cell - ! in the computational domain + ! Nullify primitive variable assignment procedure pointer s_assign_patch_primitive_variables => null() end subroutine s_finalize_assign_variables_module diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index 6f927d8b4a..eafe90b2ad 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -628,9 +628,7 @@ contains write (t_step_dir, '(A,I0,A)') '/p_all/p', proc_rank, '/0' t_step_dir = trim(case_dir) // trim(t_step_dir) - ! Checking the existence of the time-step directory, removing it, if it exists, and creating a new copy. Note that if - ! preexisting grid and/or initial condition data are to be read in from the very same location, then the above described - ! steps are not executed here but rather in the module m_start_up.f90. + ! Remove existing time-step dir if needed (unless reading preexisting data; handled in m_start_up) if (old_grid .neqv. .true.) then file_loc = trim(t_step_dir) // '/' diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index a1b5d1731b..7ba8edf582 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -48,9 +48,7 @@ module m_global_parameters real(wp) :: dx, dy, dz !< Minimum cell-widths in the x-, y- and z-coordinate directions type(bounds_info) :: x_domain, y_domain, z_domain !< Locations of the domain bounds in the x-, y- and z-coordinate directions logical :: stretch_x, stretch_y, stretch_z !< Grid stretching flags for the x-, y- and z-coordinate directions - ! Parameters of the grid stretching function for the x-, y- and z-coordinate directions. The "a" parameters are a measure of the - ! rate at which the grid is stretched while the remaining parameters are indicative of the location on the grid at which the - ! stretching begins. + ! Grid stretching: a_x/a_y/a_z = rate, x_a/y_a/z_a = location real(wp) :: a_x, a_y, a_z integer :: loops_x, loops_y, loops_z real(wp) :: x_a, y_a, z_a @@ -104,8 +102,7 @@ module m_global_parameters ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). Stands for "InDices With BUFFer". type(int_bounds_info) :: idwint(1:3) - ! Cell Indices for the entire (local) domain. In simulation and post_process, this includes the buffer region. idwbuff and - ! idwint are the same otherwise. Stands for "InDices With BUFFer". + ! Cell indices (InDices With BUFFer): includes buffer except in pre_process type(int_bounds_info) :: idwbuff(1:3) type(int_bounds_info) :: bc_x, bc_y, bc_z !< Boundary conditions in the x-, y- and z-coordinate directions integer :: shear_num !! Number of shear stress components diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 3e1f516424..ad399ac64a 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -202,13 +202,10 @@ contains x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x - ! Since the line segment patch does not allow for its boundaries to be smoothed out, the pseudo volume fraction is set to 1 - ! to ensure that only the current patch contributes to the fluid state in the cells that this patch covers. + ! Set eta=1 (no smoothing for this patch type) eta = 1._wp - ! Checking whether the line segment covers a particular cell in the domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to - ! this cell. + ! Assign patch vars if cell is covered and patch has write permission do i = 0, m if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, & & 0, 0))) then @@ -326,12 +323,10 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but - ! only in the case that smoothing of the circular patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp - ! Checking whether the circle covers a particular cell in the domain and verifying whether the current patch has permission - ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. + ! Assign patch vars if cell is covered and patch has write permission do j = 0, n do i = 0, m @@ -386,12 +381,10 @@ contains smooth_coeff = patch_icpp(patch_id)%smooth_coeff thickness = patch_icpp(patch_id)%epsilon - ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but - ! only in the case that smoothing of the circular patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp - ! Checking whether the circle covers a particular cell in the domain and verifying whether the current patch has permission - ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. + ! Assign patch vars if cell is covered and patch has write permission do j = 0, n do i = 0, m myr = sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) @@ -450,14 +443,12 @@ contains smooth_coeff = patch_icpp(patch_id)%smooth_coeff thickness = patch_icpp(patch_id)%epsilon - ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but - ! only in the case that smoothing of the circular patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp ! write for all z - ! Checking whether the circle covers a particular cell in the domain and verifying whether the current patch has permission - ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. + ! Assign patch vars if cell is covered and patch has write permission do k = 0, p do j = 0, n do i = 0, m @@ -514,12 +505,10 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Initializing the pseudo volume fraction value to 1. The value be modified as the patch is laid out on the grid, but only - ! in the case that smoothing of the elliptical patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp - ! Checking whether the ellipse covers a particular cell in the domain and verifying whether the current patch has permission - ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. + ! Assign patch vars if cell is covered and patch has write permission do j = 0, n do i = 0, m if (patch_icpp(patch_id)%smoothen) then @@ -580,13 +569,10 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Initializing the pseudo volume fraction value to 1. The value be modified as the patch is laid out on the grid, but only - ! in the case that smoothing of the ellipsoidal patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp - ! Checking whether the ellipsoid covers a particular cell in the domain and verifying whether the current patch has - ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to - ! this cell. + ! Assign patch vars if cell is covered and patch has write permission do k = 0, p do j = 0, n do i = 0, m @@ -662,13 +648,10 @@ contains y_boundary%beg = y_centroid - 0.5_wp*length_y y_boundary%end = y_centroid + 0.5_wp*length_y - ! Since the rectangular patch does not allow for its boundaries to be smoothed out, the pseudo volume fraction is set to 1 - ! to ensure that only the current patch contributes to the fluid state in the cells that this patch covers. + ! Set eta=1 (no smoothing for this patch type) eta = 1._wp - ! Checking whether the rectangle covers a particular cell in the domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to - ! this cell. + ! Assign patch vars if cell is covered and patch has write permission do j = 0, n do i = 0, m if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. y_boundary%beg <= y_cc(j) & @@ -733,13 +716,10 @@ contains b = patch_icpp(patch_id)%normal(2) c = -a*x_centroid - b*y_centroid - ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but - ! only in the case that smoothing of the sweep line patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp - ! Checking whether the region swept by the line covers a particular cell in the domain and verifying whether the current - ! patch has the permission to write to that cell. If both queries check out, the primitive variables of the current patch - ! are written to this cell. + ! Assign patch vars if cell is covered and patch has write permission do j = 0, n do i = 0, m if (patch_icpp(patch_id)%smoothen) then @@ -802,16 +782,13 @@ contains y_boundary%beg = y_centroid - 0.5_wp*length_y y_boundary%end = y_centroid + 0.5_wp*length_y - ! Since the patch doesn't allow for its boundaries to be smoothed out, the pseudo volume fraction is set to 1 to ensure that - ! only the current patch contributes to the fluid state in the cells that this patch covers. + ! Set eta=1 (no smoothing for this patch type) eta = 1._wp ! U0 is the characteristic velocity of the vortex U0 = patch_icpp(patch_id)%vel(1) ! L0 is the characteristic length of the vortex L0 = patch_icpp(patch_id)%vel(2) - ! Checking whether the patch covers a particular cell in the domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to - ! this cell. + ! Assign patch vars if cell is covered and patch has write permission do j = 0, n do i = 0, m if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. y_boundary%beg <= y_cc(j) & @@ -877,13 +854,10 @@ contains x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x - ! Since the patch doesn't allow for its boundaries to be smoothed out, the pseudo volume fraction is set to 1 to ensure that - ! only the current patch contributes to the fluid state in the cells that this patch covers. + ! Set eta=1 (no smoothing for this patch type) eta = 1._wp - ! Checking whether the line segment covers a particular cell in the domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to - ! this cell. + ! Assign patch vars if cell is covered and patch has write permission do i = 0, m if (x_boundary%beg <= x_cc(i) .and. x_boundary%end >= x_cc(i) .and. patch_icpp(patch_id)%alter_patch(patch_id_fp(i, & & 0, 0))) then @@ -1054,12 +1028,10 @@ contains smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id smooth_coeff = patch_icpp(patch_id)%smooth_coeff - ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but - ! only in the case that smoothing of the spherical patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp - ! Checking whether the sphere covers a particular cell in the domain and verifying whether the current patch has permission - ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. + ! Assign patch vars if cell is covered and patch has write permission do k = 0, p do j = 0, n do i = 0, m @@ -1131,13 +1103,10 @@ contains z_boundary%beg = z_centroid - 0.5_wp*length_z z_boundary%end = z_centroid + 0.5_wp*length_z - ! Since the cuboidal patch does not allow for its boundaries to get smoothed out, the pseudo volume fraction is set to 1 to - ! make sure that only the current patch contributes to the fluid state in the cells that this patch covers. + ! Set eta=1 (no smoothing for this patch type) eta = 1._wp - ! Checking whether the cuboid covers a particular cell in the domain and verifying whether the current patch has permission - ! to write to to that cell. If both queries check out, the primitive variables of the current patch are assigned to this - ! cell. + ! Assign patch vars if cell is covered and patch has write permission do k = 0, p do j = 0, n do i = 0, m @@ -1212,13 +1181,10 @@ contains z_boundary%beg = z_centroid - 0.5_wp*length_z z_boundary%end = z_centroid + 0.5_wp*length_z - ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but - ! only in the case that smearing of the cylindrical patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp - ! Checking whether the cylinder covers a particular cell in the domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to - ! this cell. + ! Assign patch vars if cell is covered and patch has write permission do k = 0, p do j = 0, n do i = 0, m @@ -1306,13 +1272,10 @@ contains c = patch_icpp(patch_id)%normal(3) d = -a*x_centroid - b*y_centroid - c*z_centroid - ! Initializing the pseudo volume fraction value to 1. The value will be modified as the patch is laid out on the grid, but - ! only in the case that smearing of the sweep plane patch's boundary is enabled. + ! Initialize eta=1; modified if smoothing is enabled eta = 1._wp - ! Checking whether the region swept by the plane covers a particular cell in the domain and verifying whether the current - ! patch has the permission to write to that cell. If both queries check out, the primitive variables of the current patch - ! are written to this cell. + ! Assign patch vars if cell is covered and patch has write permission do k = 0, p do j = 0, n do i = 0, m diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 084fbeb2cf..430a193372 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -20,9 +20,7 @@ module m_initial_condition implicit none - ! NOTE: The abstract interface allows for the declaration of a pointer to a procedure such that the choice of the model - ! equations does not have to be queried every time the patch primitive variables are to be assigned in a cell in the - ! computational domain. + ! NOTE: Abstract interface enables dynamic dispatch without repeated model_eqns checks type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< primitive variables type(scalar_field), allocatable, dimension(:) :: q_cons_vf !< conservative variables type(scalar_field) :: q_T_sf !< Temperature field @@ -66,9 +64,7 @@ contains allocate (mv%sf(0:m, 0:n, 0:p, 1:nnode, 1:nb)) end if - ! Setting default values for conservative and primitive variables so that in the case that the initial condition is wrongly - ! laid out on the grid the simulation component will catch the problem on start- up. The conservative variables do not need - ! to be similarly treated since they are computed directly from the primitive variables. + ! Initialize q_cons, q_prim with sentinel values to catch IC errors do i = 1, sys_size q_cons_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) ! TODO :: remove this magic number q_prim_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index b70c2907f9..37f6933c59 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -271,10 +271,7 @@ contains end if end if - ! If only the preexisting grid data files are read in and there will not be any preexisting initial condition data files - ! imported, then the directory associated with the rank of the local processor may be cleaned to make room for the new - ! pre-process data. In addition, the time-step directory that will contain the new grid and initial condition data are also - ! generated. + ! Clean processor dir and create time-step dir (unless reading preexisting IC) if (old_ic .neqv. .true.) then call s_delete_directory(trim(proc_rank_dir)) call s_create_directory(trim(proc_rank_dir) // '/0') @@ -630,11 +627,7 @@ contains integer :: j, k, l real(wp) :: r2 - ! Setting up the grid and the initial condition. If the grid is read in from preexisting grid data files, it is checked for - ! consistency. If the grid is not read in, it is generated from scratch according to the inputs provided by the user. The - ! initial condition may also be read in. It in turn is not checked for consistency since it WILL further be edited by the - ! pre-process and also because it may be incomplete at the time it is read in. Finally, when the grid and initial condition - ! are completely setup, they are written to their respective data files. + ! Setup grid (validated if read, generated if not) and IC, then write output ! Setting up grid and initial condition @@ -717,9 +710,7 @@ contains call s_mpi_initialize() - ! Rank 0 processor assigns default values to user inputs prior to reading those in from the input file. Next, the user - ! inputs are read in and their consistency is checked. The detection of any inconsistencies automatically leads to the - ! termination of the pre-process. + ! Rank 0: assign defaults, read input file, validate consistency if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index a7a3ad3210..98d4691174 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -356,8 +356,7 @@ contains !! @param cbc_loc_in CBC coordinate location subroutine s_compute_cbc_coefficients(cbc_dir_in, cbc_loc_in) - ! Description: The purpose of this subroutine is to compute the grid dependent FD and PI coefficients, or CBC coefficients, - ! provided the CBC coordinate direction and location. + ! Compute grid-dependent CBC coefficients for given direction and location ! CBC coordinate direction and location integer, intent(in) :: cbc_dir_in, cbc_loc_in diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 2c25af959f..8ac272843a 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -294,9 +294,7 @@ module m_global_parameters $:GPU_DECLARE(create='[Re_size, Re_size_max, Re_idx]') - ! The WENO average (WA) flag regulates whether the calculation of any cell- average spatial derivatives is carried out in each - ! cell by utilizing the arithmetic mean of the left and right, WENO-reconstructed, cell-boundary values or simply, the unaltered - ! left and right, WENO-reconstructed, cell- boundary values. + ! WENO averaging flag: use arithmetic mean or unaltered WENO-reconstructed cell-boundary values !> @{ real(wp) :: wa_flg !> @} @@ -882,9 +880,7 @@ contains $:GPU_UPDATE(device='[igr, igr_order, igr_iter_solver]') #:endif - ! Initializing the number of fluids for which viscous effects will be non-negligible, the number of distinctive material - ! interfaces for which surface tension will be important and also, the number of fluids for which the physical and geometric - ! curvatures of the interfaces will be computed + ! Initialize counts: viscous fluids, surface-tension interfaces, curvature interfaces Re_size = 0 Re_size_max = 0 @@ -915,9 +911,7 @@ contains E_idx = mom_idx%end + 1 if (igr) then - ! Volume fractions are stored in the indices immediately following the energy equation. IGR tracks a total of - ! (N-1) volume fractions for N fluids, hence the "-1" in adv_idx%end. If num_fluids = 1 then adv_idx%end < - ! adv_idx%beg, which skips all loops over the volume fractions since there is no volume fraction to track + ! IGR: volume fractions after energy (N-1 for N fluids; skipped when num_fluids=1) adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 adv_idx%end = E_idx + num_fluids - 1 else @@ -1052,8 +1046,7 @@ contains end if end if - ! Determining the number of fluids for which the shear and the volume Reynolds numbers, e.g. viscous effects, are - ! important + ! Count fluids with non-negligible viscous effects (Re > 0) do i = 1, num_fluids if (fluid_pp(i)%Re(1) > 0) Re_size(1) = Re_size(1) + 1 if (fluid_pp(i)%Re(2) > 0) Re_size(2) = Re_size(2) + 1 @@ -1181,9 +1174,7 @@ contains end do end if - ! Configuring the WENO average flag that will be used to regulate whether any spatial derivatives are to computed in each - ! cell by using the arithmetic mean of left and right, WENO-reconstructed, cell-boundary values or otherwise, the unaltered - ! left and right, WENO-reconstructed, cell-boundary values + ! Configure WENO averaging flag (arithmetic mean vs. unaltered values) wa_flg = 0._wp; if (weno_avg) wa_flg = 1._wp $:GPU_UPDATE(device='[wa_flg]') diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index 18abe9bdde..5be5670396 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -145,8 +145,7 @@ contains call get_bounding_indices(center(1) - radius, center(1) + radius, x_cc, il, ir) call get_bounding_indices(center(2) - radius, center(2) + radius, y_cc, jl, jr) - ! Checking whether the circle covers a particular cell in the domain and verifying whether the current patch has permission - ! to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to this cell. + ! Assign primitive variables if circle covers cell and patch has write permission $:GPU_PARALLEL_LOOP(private='[i, j]', copyin='[encoded_patch_id, center, radius]', collapse=2) do j = jl, jr @@ -522,9 +521,7 @@ contains call get_bounding_indices(center(1) - corner_distance, center(1) + corner_distance, x_cc, il, ir) call get_bounding_indices(center(2) - corner_distance, center(2) + corner_distance, y_cc, jl, jr) - ! Checking whether the rectangle covers a particular cell in the domain and verifying whether the current patch has the - ! permission to write to that cell. If both queries check out, the primitive variables of the current patch are assigned to - ! this cell. + ! Assign primitive variables if rectangle covers cell and patch has write permission $:GPU_PARALLEL_LOOP(private='[i, j, xy_local]', copyin='[encoded_patch_id, center, length, inverse_rotation, x_cc, & & y_cc]', collapse=2) do j = jl, jr diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index 98e9e0c47a..61e48f038d 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -292,9 +292,7 @@ contains type(scalar_field), dimension(:), intent(in) :: v_vf integer, intent(in) :: muscl_dir integer :: j, k, l, q !< Generic loop iterators - ! Determining the number of cell-average variables which will be muscl-reconstructed and mapping their indical bounds in the - ! x-, y- and z-directions to those in the s1-, s2- and s3-directions as to reshape the inputted data in the coordinate - ! direction of the muscl reconstruction + ! Determine MUSCL-reconstructed variables and map coordinate directions v_size = ubound(v_vf, 1) $:GPU_UPDATE(device='[v_size]') diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index a4e8044773..5e941f61f0 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -50,8 +50,7 @@ module m_riemann_solvers $:GPU_DECLARE(create='[flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf]') !> @} - ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as part of Riemann problem solution and is used to - ! evaluate the source flux. + ! Cell-boundary velocity from Riemann solution; used for source flux real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsx_vf real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsy_vf diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 51cd3764c6..7d12f80faf 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -1032,9 +1032,7 @@ contains #endif #endif - ! The rank 0 processor assigns default values to the user inputs prior to reading them in from the input file. Next, the - ! user inputs are read and their consistency is checked. The identification of any inconsistencies will result in the - ! termination of the simulation. + ! Rank 0: assign defaults, read input file, validate (abort on inconsistencies) if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() @@ -1056,8 +1054,7 @@ contains #endif end if - ! Broadcasting the user inputs to all of the processors and performing the parallel computational domain decomposition. - ! Neither procedure has to be carried out if the simulation is in fact not truly executed in parallel. + ! Broadcast user inputs and decompose domain (skipped in serial) call s_mpi_bcast_user_inputs() diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 2e9c1e5839..d511249bcb 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -43,11 +43,11 @@ contains end subroutine s_initialize_viscous_module - !> The purpose of this subroutine is to compute the viscous - ! stress tensor for the cells directly next to the axis in cylindrical coordinates. This is necessary to avoid the 1/r - ! singularity that arises at the cell boundary coinciding with the axis, i.e., y_cb(-1) = 0. @param q_prim_vf Cell-average - ! primitive variables @param grad_x_vf Cell-average primitive variable derivatives, x-dir @param grad_y_vf Cell-average - ! primitive variable derivatives, y-dir @param grad_z_vf Cell-average primitive variable derivatives, z-dir + !> Compute viscous stress tensor near cylindrical axis, avoiding 1/r singularity at y_cb(-1)=0 + !! @param q_prim_vf Cell-average primitive variables + !! @param grad_x_vf Cell-average primitive variable derivatives, x-direction + !! @param grad_y_vf Cell-average primitive variable derivatives, y-direction + !! @param grad_z_vf Cell-average primitive variable derivatives, z-direction subroutine s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, grad_x_vf, grad_y_vf, grad_z_vf, tau_Re_vf, ix, iy, iz) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index ec29dd1718..aaba3cfd67 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -185,8 +185,7 @@ contains real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil - ! Determining the number of cells, the cell-boundary locations and the boundary conditions in the coordinate direction - ! selected for the WENO reconstruction + ! Determine cell count, boundary locations, and BCs for selected WENO direction if (weno_dir == 1) then s = m; s_cb => x_cb; bc_s = bc_x @@ -1389,9 +1388,7 @@ contains integer, intent(in) :: weno_dir integer :: j, k, l, q - ! Determining the number of cell-average variables which will be WENO-reconstructed and mapping their indical bounds in the - ! x-, y- and z-directions to those in the s1-, s2- and s3-directions as to reshape the inputted data in the coordinate - ! direction of the WENO reconstruction + ! Determine WENO-reconstructed variables and map coordinate directions v_size = ubound(v_vf, 1) $:GPU_UPDATE(device='[v_size]') From a1af5094cb5e1d440aeb043ea8e631ce3bd9f973 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 20:04:01 -0400 Subject: [PATCH 11/25] Fix spelling errors and remove redundant comments across codebase --- src/common/include/2dHardcodedIC.fpp | 2 +- src/common/include/3dHardcodedIC.fpp | 2 +- src/common/m_boundary_common.fpp | 6 +- src/common/m_delay_file_access.f90 | 1 - src/common/m_mpi_common.fpp | 57 +------- src/common/m_variables_conversion.fpp | 2 +- src/post_process/m_data_input.f90 | 79 ++--------- src/post_process/m_data_output.fpp | 168 +++-------------------- src/post_process/m_derived_variables.fpp | 81 ++++------- src/post_process/m_start_up.fpp | 94 +++---------- src/pre_process/m_assign_variables.fpp | 49 +------ src/pre_process/m_data_output.fpp | 95 ++++--------- src/pre_process/m_initial_condition.fpp | 28 +--- src/pre_process/m_mpi_proxy.fpp | 10 +- src/pre_process/m_perturbation.fpp | 16 +-- src/pre_process/m_start_up.fpp | 137 ++++-------------- src/simulation/m_body_forces.fpp | 4 - src/simulation/m_data_output.fpp | 74 ++-------- src/simulation/m_ibm.fpp | 2 +- src/simulation/m_rhs.fpp | 7 - src/simulation/m_start_up.fpp | 58 +------- 21 files changed, 167 insertions(+), 805 deletions(-) diff --git a/src/common/include/2dHardcodedIC.fpp b/src/common/include/2dHardcodedIC.fpp index 8b22aec882..c7aca27a98 100644 --- a/src/common/include/2dHardcodedIC.fpp +++ b/src/common/include/2dHardcodedIC.fpp @@ -23,7 +23,7 @@ ! Volume Fractions q_prim_vf(advxb)%sf(i, j, 0) = eps q_prim_vf(advxe)%sf(i, j, 0) = 1._wp - eps - ! Denssities + ! Densities q_prim_vf(contxb)%sf(i, j, 0) = eps*1000._wp q_prim_vf(contxe)%sf(i, j, 0) = (1._wp - eps)*1._wp ! Pressure diff --git a/src/common/include/3dHardcodedIC.fpp b/src/common/include/3dHardcodedIC.fpp index 1e9854b579..b4ca939a49 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -11,7 +11,7 @@ real(wp), dimension(0:n, 0:p) :: rcut_arr integer :: l, q, s ! Iterators for reading input files integer :: start, end ! Ints to keep track of position in file - character(len=1000) :: line ! String to store line in ile + character(len=1000) :: line ! String to store line in file character(len=25) :: value ! String to store value in line integer :: NJet ! Number of jets diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 2b5eae1d12..6563e55379 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -269,7 +269,6 @@ contains $:END_GPU_PARALLEL_LOOP() end if #:endif - ! END: Population of Buffers in z-direction end subroutine s_populate_variables_buffers @@ -1857,7 +1856,7 @@ contains !! locations and cell-width distributions, based on the boundary conditions. subroutine s_populate_grid_variables_buffers - integer :: i !< Generic loop iterator + integer :: i #ifdef MFC_SIMULATION ! Required for compatibility between codes @@ -1922,7 +1921,6 @@ contains do i = 1, buff_size x_cc(m + i) = x_cc(m + (i - 1)) + (dx(m + (i - 1)) + dx(m + i))/2._wp end do - ! END: Population of Buffers in x-direction ! Population of Buffers in y-direction @@ -1979,7 +1977,6 @@ contains do i = 1, buff_size y_cc(n + i) = y_cc(n + (i - 1)) + (dy(n + (i - 1)) + dy(n + i))/2._wp end do - ! END: Population of Buffers in y-direction ! Population of Buffers in z-direction @@ -2036,7 +2033,6 @@ contains do i = 1, buff_size z_cc(p + i) = z_cc(p + (i - 1)) + (dz(p + (i - 1)) + dz(p + i))/2._wp end do - ! END: Population of Buffers in z-direction #endif end subroutine s_populate_grid_variables_buffers diff --git a/src/common/m_delay_file_access.f90 b/src/common/m_delay_file_access.f90 index eb7cbf2f1f..0c2f57bd8a 100644 --- a/src/common/m_delay_file_access.f90 +++ b/src/common/m_delay_file_access.f90 @@ -25,7 +25,6 @@ impure subroutine DelayFileAccess(ProcessRank) nFileAccessDelayIterations = (ProcessRank/N_PROCESSES_FILE_ACCESS)*FILE_ACCESS_DELAY_UNIT do iDelay = 1, nFileAccessDelayIterations - ! Wait my turn call random_number(Number) Dummy = Number*Number end do diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 531099cbf0..7ad96ee897 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -83,25 +83,19 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Initializing the MPI environment call MPI_INIT(ierr) - ! Checking whether the MPI environment has been properly initialized if (ierr /= MPI_SUCCESS) then print '(A)', 'Unable to initialize MPI environment. Exiting.' call MPI_ABORT(MPI_COMM_WORLD, 1, ierr) end if - ! Querying the number of processors available for the job call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr) - ! Querying the rank of the local processor call MPI_COMM_RANK(MPI_COMM_WORLD, proc_rank, ierr) #else - ! Serial run only has 1 processor num_procs = 1 - ! Local processor rank is 0 proc_rank = 0 #endif @@ -119,10 +113,8 @@ contains integer, dimension(1) :: airfoil_glb, airfoil_loc, airfoil_start #ifdef MFC_MPI - ! Generic loop iterator integer :: i, j integer :: ierr !< Generic flag used to identify and report MPI errors - ! Altered system size for the lagrangian subgrid bubble model integer :: alt_sys if (present(beta)) then @@ -201,7 +193,6 @@ contains integer, dimension(3) :: sf_start_idx #ifdef MFC_MPI - ! Generic loop iterator integer :: i, j, q, k, l, m_ds, n_ds, p_ds, ierr sf_start_idx = (/0, 0, 0/) @@ -324,8 +315,6 @@ contains #ifdef MFC_SIMULATION #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Reducing local extrema of ICFL, VCFL, CCFL and Rc numbers to their global extrema and bookkeeping the results on the rank - ! 0 processor call MPI_REDUCE(icfl_max_loc, icfl_max_glb, 1, mpi_p, MPI_MAX, 0, MPI_COMM_WORLD, ierr) @@ -357,7 +346,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) #endif @@ -374,7 +362,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure if (loc(var_loc) == loc(var_glb)) then call MPI_Allreduce(MPI_IN_PLACE, var_glb, num_vectors*vector_length, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -399,7 +386,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) #else @@ -420,7 +406,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, MPI_COMM_WORLD, ierr) #endif @@ -439,7 +424,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Performing the reduction procedure call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MAX, MPI_COMM_WORLD, ierr) #endif @@ -455,13 +439,9 @@ contains real(wp), intent(inout) :: var_loc #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors - ! Temporary storage variable that holds the reduced minimum value + integer :: ierr !< Generic flag used to identify and report MPI errors real(wp) :: var_glb - ! Performing reduction procedure and eventually storing its result into the variable that was initially inputted into the - ! subroutine - call MPI_REDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(var_glb, 1, mpi_p, 0, MPI_COMM_WORLD, ierr) @@ -486,9 +466,6 @@ contains !> Temporary storage variable that holds the reduced maximum value and the rank of the processor with which the value is !! associated real(wp), dimension(2) :: var_glb - ! Performing reduction procedure and eventually storing its result into the variable that was initially inputted into the - ! subroutine - call MPI_REDUCE(var_loc, var_glb, 1, mpi_2p, MPI_MAXLOC, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(var_glb, 1, mpi_2p, 0, MPI_COMM_WORLD, ierr) @@ -522,7 +499,6 @@ contains stop 1 end if #else - ! Terminating the MPI environment if (present(code)) then call MPI_ABORT(MPI_COMM_WORLD, code, ierr) else @@ -537,7 +513,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Calling MPI_BARRIER call MPI_BARRIER(MPI_COMM_WORLD, ierr) #endif @@ -549,7 +524,6 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! Finalizing the MPI environment call MPI_FINALIZE(ierr) #endif @@ -917,7 +891,6 @@ contains $:END_GPU_PARALLEL_LOOP() end if #:else - ! Unpacking buffer from bc_z%beg $:GPU_PARALLEL_LOOP(collapse=4,private='[r]') do i = 1, nVar do l = -buff_size, -1 @@ -1128,7 +1101,6 @@ contains ! Finding the Cartesian coordinates of the local process call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 3, proc_coords, ierr) - ! END: 3D Cartesian Processor Topology ! Global Parameters for z-direction @@ -1241,7 +1213,6 @@ contains ! Finding the Cartesian coordinates of the local process call MPI_CART_COORDS(MPI_COMM_CART, proc_rank, 2, proc_coords, ierr) end if - ! END: 2D Cartesian Processor Topology ! Global Parameters for y-direction @@ -1410,91 +1381,65 @@ contains #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors - ! MPI Communication in x-direction if (mpi_dir == 1) then if (pbc_loc == -1) then ! PBC at the beginning if (bc_x%end >= 0) then ! PBC at the beginning and end - - ! Send/receive buffer to/from bc_x%end/bc_x%beg call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(-buff_size), buff_size, mpi_p, & & bc_x%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only - ! Send/receive buffer to/from bc_x%beg/bc_x%beg call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(-buff_size), buff_size, mpi_p, bc_x%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end if (bc_x%beg >= 0) then ! PBC at the end and beginning - - ! Send/receive buffer to/from bc_x%beg/bc_x%end call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(m + 1), buff_size, mpi_p, bc_x%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only - ! Send/receive buffer to/from bc_x%end/bc_x%end call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(m + 1), buff_size, mpi_p, & & bc_x%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if - ! END: MPI Communication in x-direction - - ! MPI Communication in y-direction else if (mpi_dir == 2) then if (pbc_loc == -1) then ! PBC at the beginning if (bc_y%end >= 0) then ! PBC at the beginning and end - - ! Send/receive buffer to/from bc_y%end/bc_y%beg call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(-buff_size), buff_size, mpi_p, & & bc_y%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only - ! Send/receive buffer to/from bc_y%beg/bc_y%beg call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(-buff_size), buff_size, mpi_p, bc_y%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end if (bc_y%beg >= 0) then ! PBC at the end and beginning - - ! Send/receive buffer to/from bc_y%beg/bc_y%end call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(n + 1), buff_size, mpi_p, bc_y%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only - ! Send/receive buffer to/from bc_y%end/bc_y%end call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(n + 1), buff_size, mpi_p, & & bc_y%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if - ! END: MPI Communication in y-direction - - ! MPI Communication in z-direction else if (pbc_loc == -1) then ! PBC at the beginning if (bc_z%end >= 0) then ! PBC at the beginning and end - - ! Send/receive buffer to/from bc_z%end/bc_z%beg call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(-buff_size), buff_size, mpi_p, & & bc_z%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the beginning only - ! Send/receive buffer to/from bc_z%beg/bc_z%beg call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(-buff_size), buff_size, mpi_p, bc_z%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if else ! PBC at the end if (bc_z%beg >= 0) then ! PBC at the end and beginning - - ! Send/receive buffer to/from bc_z%beg/bc_z%end call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(p + 1), buff_size, mpi_p, bc_z%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) else ! PBC at the end only - ! Send/receive buffer to/from bc_z%end/bc_z%end call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(p + 1), buff_size, mpi_p, & & bc_z%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if end if - ! END: MPI Communication in z-direction #endif end subroutine s_mpi_sendrecv_grid_variables_buffers diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index f7310335a0..e2f996c9f3 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -188,7 +188,7 @@ contains rho = q_vf(1)%sf(i, j, k) gamma = q_vf(gamma_idx)%sf(i, j, k) pi_inf = q_vf(pi_inf_idx)%sf(i, j, k) - qv = 0._wp ! keep this value nill for now. For future adjustment + qv = 0._wp ! keep this value nil for now. For future adjustment ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated #ifdef MFC_POST_PROCESS diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index 33f1ef3527..fdce73ca18 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -6,12 +6,12 @@ module m_data_input #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi #endif - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types + use m_global_parameters + use m_mpi_proxy use m_mpi_common use m_compile_specific use m_boundary_common @@ -65,12 +65,9 @@ impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_ character(LEN=len_trim(t_step_dir) + 10) :: file_loc logical :: file_check - ! Checking whether direction_cb.dat exists - file_loc = trim(t_step_dir) // '/' // direction // '_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) - ! Reading direction_cb.dat if it exists, exiting otherwise if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) cb_array(-1:size_dim) @@ -79,10 +76,7 @@ impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_ call s_mpi_abort('File ' // direction // '_cb.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if - ! Computing the cell-width distribution d_array(0:size_dim) = cb_array(0:size_dim) - cb_array(-1:size_dim - 1) - - ! Computing the cell-center locations cc_array(0:size_dim) = cb_array(-1:size_dim - 1) + d_array(0:size_dim)/2._wp end subroutine s_read_grid_data_direction @@ -98,18 +92,14 @@ impure subroutine s_setup_mpi_io_params(data_size, m_MOK, n_MOK, p_MOK, WP_MOK, integer(KIND=MPI_OFFSET_KIND), intent(out) :: m_MOK, n_MOK, p_MOK integer(KIND=MPI_OFFSET_KIND), intent(out) :: WP_MOK, MOK, str_MOK, NVARS_MOK - ! Initialize MPI data I/O - if (ib) then call s_initialize_mpi_data(q_cons_vf, ib_markers) else call s_initialize_mpi_data(q_cons_vf) end if - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) - ! Resize some integers so MPI can read even the biggest file m_MOK = int(m_glb + 1, MPI_OFFSET_KIND) n_MOK = int(n_glb + 1, MPI_OFFSET_KIND) p_MOK = int(p_glb + 1, MPI_OFFSET_KIND) @@ -213,26 +203,21 @@ end subroutine s_allocate_field_arrays !! @param t_step Current time-step impure subroutine s_read_serial_data_files(t_step) - integer, intent(in) :: t_step - character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_dir !< Location of the time-step directory associated with t_step - character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc !< Generic string used to store the location of a particular file - !> Used to store the variable position, in character form, of the currently manipulated conservative variable file + integer, intent(in) :: t_step + character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_dir + character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num - !> Location of the time-step directory associated with t_step - character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_ib_dir - logical :: dir_check !< Generic logical used to test the existence of a particular folder - logical :: file_check !< Generic logical used to test the existence of a particular file - integer :: i !< Generic loop iterator - ! Setting location of time-step folder based on current time-step + character(LEN=len_trim(case_dir) + 2*name_len) :: t_step_ib_dir + logical :: dir_check + logical :: file_check + integer :: i write (t_step_dir, '(A,I0,A,I0)') '/p_all/p', proc_rank, '/', t_step t_step_dir = trim(case_dir) // trim(t_step_dir) - ! Inquiring as to the existence of the time-step directory file_loc = trim(t_step_dir) // '/.' call my_inquire(file_loc, dir_check) - ! If the time-step directory is missing, the post-process exits. if (dir_check .neqv. .true.) then call s_mpi_abort('Time-step folder ' // trim(t_step_dir) // ' is missing. Exiting.') end if @@ -243,7 +228,6 @@ impure subroutine s_read_serial_data_files(t_step) call s_assign_default_bc_type(bc_type) end if - ! Reading the Grid Data Files using helper subroutine call s_read_grid_data_direction(t_step_dir, 'x', x_cb, dx, x_cc, m) if (n > 0) then @@ -254,15 +238,11 @@ impure subroutine s_read_serial_data_files(t_step) end if end if - ! Reading the Conservative Variables Data Files do i = 1, sys_size - ! Checking whether the data file associated with the variable position of currently manipulated conservative variable - ! exists write (file_num, '(I0)') i file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) - ! Reading the data file if it exists, exiting otherwise if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) q_cons_vf(i)%sf(0:m, 0:n, 0:p) @@ -275,7 +255,6 @@ impure subroutine s_read_serial_data_files(t_step) end if end do - ! Reading IB data using helper subroutine call s_read_ib_data_files(t_step_dir) end subroutine s_read_serial_data_files @@ -313,7 +292,6 @@ impure subroutine s_read_parallel_data_files(t_step) stride = 1 end if - ! Read in cell boundary locations in x-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'x_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -333,15 +311,11 @@ impure subroutine s_read_parallel_data_files(t_step) call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if - ! Assigning local cell boundary locations x_cb(-1:m) = x_cb_glb((start_idx(1) - 1):(start_idx(1) + m)) - ! Computing the cell width distribution dx(0:m) = x_cb(0:m) - x_cb(-1:m - 1) - ! Computing the cell center location x_cc(0:m) = x_cb(-1:m - 1) + dx(0:m)/2._wp if (n > 0) then - ! Read in cell boundary locations in y-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'y_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -361,15 +335,11 @@ impure subroutine s_read_parallel_data_files(t_step) call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if - ! Assigning local cell boundary locations y_cb(-1:n) = y_cb_glb((start_idx(2) - 1):(start_idx(2) + n)) - ! Computing the cell width distribution dy(0:n) = y_cb(0:n) - y_cb(-1:n - 1) - ! Computing the cell center location y_cc(0:n) = y_cb(-1:n - 1) + dy(0:n)/2._wp if (p > 0) then - ! Read in cell boundary locations in z-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'z_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -389,11 +359,8 @@ impure subroutine s_read_parallel_data_files(t_step) call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if - ! Assigning local cell boundary locations z_cb(-1:p) = z_cb_glb((start_idx(3) - 1):(start_idx(3) + p)) - ! Computing the cell width distribution dz(0:p) = z_cb(0:p) - z_cb(-1:p - 1) - ! Computing the cell center location z_cc(0:p) = z_cb(-1:p - 1) + dz(0:p)/2._wp end if end if @@ -431,7 +398,6 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, if (file_per_process) then call s_int_to_str(t_step, t_step_string) - ! Open the file to read conservative variables write (file_loc, '(I0,A1,I7.7,A)') t_step, '_', proc_rank, '.dat' file_loc = trim(case_dir) // '/restart_data/lustre_' // trim(t_step_string) // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -442,7 +408,6 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, if (down_sample) then call s_initialize_mpi_data_ds(q_cons_temp) else - ! Initialize MPI data I/O if (ib) then call s_initialize_mpi_data(q_cons_vf, ib_markers) else @@ -451,14 +416,11 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, end if if (down_sample) then - ! Size of local arrays data_size = (m + 3)*(n + 3)*(p + 3) else - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) end if - ! Resize some integers so MPI can read even the biggest file m_MOK = int(m_glb + 1, MPI_OFFSET_KIND) n_MOK = int(n_glb + 1, MPI_OFFSET_KIND) p_MOK = int(p_glb + 1, MPI_OFFSET_KIND) @@ -467,7 +429,6 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - ! Read the data for each variable if (bubbles_euler .or. elasticity .or. mhd) then do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) @@ -494,7 +455,6 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if else - ! Open the file to read conservative variables write (file_loc, '(I0,A)') t_step, '.dat' file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -504,11 +464,9 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, call s_setup_mpi_io_params(data_size, m_MOK, n_MOK, p_MOK, WP_MOK, MOK, str_MOK, NVARS_MOK) - ! Read the data for each variable do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) @@ -530,20 +488,13 @@ end subroutine s_read_parallel_conservative_data !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_data_input_module - integer :: i !< Generic loop iterator - ! Allocating the parts of the conservative and primitive variables that do not require the direct knowledge of the - ! dimensionality of the simulation + integer :: i allocate (q_cons_vf(1:sys_size)) allocate (q_prim_vf(1:sys_size)) allocate (q_cons_temp(1:sys_size)) - ! Allocating the parts of the conservative and primitive variables that do require the direct knowledge of the - ! dimensionality of the simulation using helper subroutine - - ! Simulation is at least 2D if (n > 0) then - ! Simulation is 3D if (p > 0) then call s_allocate_field_arrays(-buff_size, m + buff_size, n + buff_size, p + buff_size) if (down_sample) then @@ -552,15 +503,12 @@ impure subroutine s_initialize_data_input_module end do end if else - ! Simulation is 2D call s_allocate_field_arrays(-buff_size, m + buff_size, n + buff_size, 0) end if else - ! Simulation is 1D call s_allocate_field_arrays(-buff_size, m + buff_size, 0, 0) end if - ! Allocating arrays to store the bc types allocate (bc_type(1:num_dims, 1:2)) allocate (bc_type(1, 1)%sf(0:0, 0:n, 0:p)) @@ -585,8 +533,7 @@ end subroutine s_initialize_data_input_module !> Deallocation procedures for the module impure subroutine s_finalize_data_input_module - integer :: i !< Generic loop iterator - ! Deallocating the conservative and primitive variables + integer :: i do i = 1, sys_size deallocate (q_cons_vf(i)%sf) diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 9e8e9208ea..91ebee57df 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -5,10 +5,10 @@ !> @brief Writes post-processed grid and flow-variable data to Silo-HDF5 or binary database files module m_data_output - use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters - use m_derived_variables !< Procedures used to compute quantities derived - use m_mpi_proxy ! Message passing interface (MPI) module proxy + use m_derived_types + use m_global_parameters + use m_derived_variables + use m_mpi_proxy use m_compile_specific use m_helper use m_variables_conversion @@ -77,17 +77,9 @@ contains !> @brief Allocate storage arrays, configure output directories, and count flow variables for formatted database output. impure subroutine s_initialize_data_output_module() - ! Description: Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module - - ! Generic string used to store the location of a particular file character(LEN=len_trim(case_dir) + 2*name_len) :: file_loc - - ! Generic logical used to test the existence of a particular folder - logical :: dir_check - integer :: i - - ! Allocating the generic storage for the flow variable(s) that are going to be written to the formatted database file(s). - ! Note once more that the root variable is only required for 1D computations. + 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)) if (grid_geometry == 3) then @@ -166,9 +158,7 @@ contains end if end if - ! Generating Silo-HDF5 Directory Tree if (format == 1) then - ! Creating the directory associated with the local process dbdir = trim(case_dir) // '/silo_hdf5' write (proc_rank_dir, '(A,I0)') '/p', proc_rank @@ -182,7 +172,6 @@ contains call s_create_directory(trim(proc_rank_dir)) end if - ! Creating the directory associated with the root process if (proc_rank == 0) then rootdir = trim(dbdir) // '/root' @@ -193,10 +182,7 @@ contains call s_create_directory(trim(rootdir)) end if end if - - ! Generating Binary Directory Tree else - ! Creating the directory associated with the local process dbdir = trim(case_dir) // '/binary' write (proc_rank_dir, '(A,I0)') '/p', proc_rank @@ -211,7 +197,6 @@ contains call s_create_directory(trim(proc_rank_dir)) end if - ! Creating the directory associated with the root process if (n == 0 .and. proc_rank == 0) then rootdir = trim(dbdir) // '/root' @@ -245,13 +230,9 @@ contains dbfile = 1 end if - ! Querying Number of Flow Variable(s) in Binary Output - if (format == 2) then - ! Initializing the counter of the number of flow variable(s) to be written to the formatted database file(s) dbvars = 0 - ! Partial densities if ((model_eqns == 2) .or. (model_eqns == 3)) then do i = 1, num_fluids if (alpha_rho_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then @@ -260,7 +241,6 @@ contains end do end if - ! Density if ((rho_wrt .or. (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) .and. (.not. relativity)) then dbvars = dbvars + 1 end if @@ -268,37 +248,24 @@ contains if (relativity .and. (rho_wrt .or. prim_vars_wrt)) dbvars = dbvars + 1 if (relativity .and. (rho_wrt .or. cons_vars_wrt)) dbvars = dbvars + 1 - ! Momentum do i = 1, E_idx - mom_idx%beg if (mom_wrt(i) .or. cons_vars_wrt) dbvars = dbvars + 1 end do - ! Velocity do i = 1, E_idx - mom_idx%beg if (vel_wrt(i) .or. prim_vars_wrt) dbvars = dbvars + 1 end do - ! Flux limiter function do i = 1, E_idx - mom_idx%beg if (flux_wrt(i)) dbvars = dbvars + 1 end do - ! Energy if (E_wrt .or. cons_vars_wrt) dbvars = dbvars + 1 - - ! Pressure if (pres_wrt .or. prim_vars_wrt) dbvars = dbvars + 1 - - ! Elastic stresses if (hypoelasticity) dbvars = dbvars + (num_dims*(num_dims + 1))/2 - - ! Damage state variable if (cont_damage) dbvars = dbvars + 1 - - ! Hyperbolic cleaning for MHD if (hyper_cleaning) dbvars = dbvars + 1 - ! Magnetic field if (mhd) then if (n == 0) then dbvars = dbvars + 2 @@ -307,7 +274,6 @@ contains end if end if - ! Volume fraction(s) if ((model_eqns == 2) .or. (model_eqns == 3)) then do i = 1, num_fluids - 1 if (alpha_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then @@ -320,26 +286,19 @@ contains end if end if - ! Specific heat ratio function if (gamma_wrt .or. (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) then dbvars = dbvars + 1 end if - ! Specific heat ratio if (heat_ratio_wrt) dbvars = dbvars + 1 - ! Liquid stiffness function if (pi_inf_wrt .or. (model_eqns == 1 .and. (cons_vars_wrt .or. prim_vars_wrt))) then dbvars = dbvars + 1 end if - ! Liquid stiffness if (pres_inf_wrt) dbvars = dbvars + 1 - - ! Speed of sound if (c_wrt) dbvars = dbvars + 1 - ! Vorticity if (p > 0) then do i = 1, num_vels if (omega_wrt(i)) dbvars = dbvars + 1 @@ -350,12 +309,9 @@ contains end do end if - ! Numerical Schlieren function if (schlieren_wrt) dbvars = dbvars + 1 end if - ! END: Querying Number of Flow Variable(s) in Binary Output - end subroutine s_initialize_data_output_module !> @brief Compute the cell-index bounds for the user-specified partial output domain in each coordinate direction. @@ -396,34 +352,20 @@ contains !> @brief Open (or create) the Silo-HDF5 or Binary formatted database slave and master files for a given time step. impure subroutine s_open_formatted_database_file(t_step) - ! Open/create DB file for current time-step; rank 0 creates master file (Silo only) - - ! Time-step that is currently being post-processed - integer, intent(in) :: t_step - - ! Generic string used to store the location of a particular file + integer, intent(in) :: t_step character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc - integer :: ierr !< Generic flag used to identify and report database errors - ! Silo-HDF5 Database Format + integer :: ierr if (format == 1) then - ! Generating the relative path to the formatted database slave file, that is to be opened for the current time-step, - ! t_step write (file_loc, '(A,I0,A)') '/', t_step, '.silo' file_loc = trim(proc_rank_dir) // trim(file_loc) - ! Creating formatted database slave file at the above location and setting up the structure of the file and its header - ! info ierr = DBCREATE(trim(file_loc), len_trim(file_loc), DB_CLOBBER, DB_LOCAL, 'MFC v3.0', 8, DB_HDF5, dbfile) - ! Verifying that the creation and setup process of the formatted database slave file has been performed without errors. - ! If this is not the case, the post-process exits. if (dbfile == -1) then call s_mpi_abort('Unable to create Silo-HDF5 database ' // 'slave file ' // trim(file_loc) // '. ' // 'Exiting.') end if - ! Next, analogous steps to the ones above are carried out by the root process to create and setup the formatted database - ! master file. if (proc_rank == 0) then write (file_loc, '(A,I0,A)') '/collection_', t_step, '.silo' file_loc = trim(rootdir) // trim(file_loc) @@ -435,26 +377,16 @@ contains & // 'Exiting.') end if end if - - ! Binary Database Format else - ! Generating the relative path to the formatted database slave file, that is to be opened for the current time-step, - ! t_step write (file_loc, '(A,I0,A)') '/', t_step, '.dat' file_loc = trim(proc_rank_dir) // trim(file_loc) - ! Creating the formatted database slave file, at the previously precised relative path location, and setting up its - ! structure open (dbfile, IOSTAT=err, FILE=trim(file_loc), form='unformatted', STATUS='replace') - ! Verifying that the creation and setup process of the formatted database slave file has been performed without errors. - ! If this is not the case, the post-process exits. if (err /= 0) then call s_mpi_abort('Unable to create Binary database slave ' // 'file ' // trim(file_loc) // '. Exiting.') end if - ! Further defining the structure of the formatted database slave file by describing in it the dimensionality of - ! post-processed data as well as the total number of flow variable(s) that will eventually be stored in it 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 @@ -462,8 +394,6 @@ contains write (dbfile) m, n, p, dbvars end if - ! Next, analogous steps to the ones above are carried out by the root process to create and setup the formatted database - ! master file. Note that this is only done in multidimensional cases. if (n == 0 .and. proc_rank == 0) then write (file_loc, '(A,I0,A)') '/', t_step, '.dat' file_loc = trim(rootdir) // trim(file_loc) @@ -487,12 +417,11 @@ contains !> @brief Open the interface data file for appending extracted interface coordinates. impure subroutine s_open_intf_data_file() - character(LEN=path_len + 3*name_len) :: file_path !< Relative path to a file in the case directory + character(LEN=path_len + 3*name_len) :: file_path write (file_path, '(A)') '/intf_data.dat' file_path = trim(case_dir) // trim(file_path) - ! Opening the simulation data file open (211, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') end subroutine s_open_intf_data_file @@ -500,12 +429,11 @@ contains !> @brief Open the energy data file for appending volume-integrated energy budget quantities. impure subroutine s_open_energy_data_file() - character(LEN=path_len + 3*name_len) :: file_path !< Relative path to a file in the case directory + character(LEN=path_len + 3*name_len) :: file_path write (file_path, '(A)') '/eng_data.dat' file_path = trim(case_dir) // trim(file_path) - ! Opening the simulation data file open (251, FILE=trim(file_path), form='formatted', POSITION='append', STATUS='unknown') end subroutine s_open_energy_data_file @@ -513,26 +441,13 @@ contains !> @brief Write the computational grid (cell-boundary coordinates) to the formatted database slave and master files. impure subroutine s_write_grid_to_formatted_database_file(t_step) - ! Description: The general objective of this subroutine is to write the necessary grid data to the formatted database file, - ! for the current time-step, t_step. The local processor will write the grid data of the domain segment that it is in charge - ! of to the formatted database slave file. The root process will additionally take care of linking that grid data in the - ! formatted database master file. In the Silo- HDF5 database format, the spatial extents of each local process grid are also - ! written to the master file. In the Binary format, note that no master file is maintained in multidimensions. Finally, in - ! 1D, no grid data is written within this subroutine for the Silo-HDF5 format because curve objects rather than - ! quadrilateral meshes are used. For curve objects, in contrast to the quadrilateral mesh objects, the grid data is included - ! side by side with the flow variable data. Then, in this case, we take care of writing both the grid and the flow variable - ! data in the subroutine s_write_variable_to_formatted_database_file. Time-step that is currently being post-processed integer, intent(in) :: t_step - ! Bookkeeping variables storing the name and type of mesh that is handled by the local processor(s). Note that due to an - ! internal NAG Fortran compiler problem, these two variables could not be allocated dynamically. + ! NAG compiler requires these to be statically sized character(LEN=4*name_len), dimension(num_procs) :: meshnames integer, dimension(num_procs) :: meshtypes - - ! Generic loop iterator - integer :: i - integer :: ierr !< Generic flag used to identify and report database errors - ! Silo-HDF5 Database Format + integer :: i + integer :: ierr if (format == 1) then ! For multidimensional data sets, the spatial extents of all of the grid(s) handled by the local processor(s) are @@ -600,9 +515,6 @@ contains & DB_DOUBLE, DB_COLLINEAR, optlist, ierr) err = DBFREEOPTLIST(optlist) end if - ! END: Silo-HDF5 Database Format - - ! Binary Database Format else if (format == 2) then ! Multidimensional local grid data is written to the formatted database slave file. Recall that no master file to ! maintained in multidimensions. @@ -666,30 +578,14 @@ contains !> @brief Write a single flow variable field to the formatted database slave and master files for a given time step. impure subroutine s_write_variable_to_formatted_database_file(varname, t_step) - ! Description: The goal of this subroutine is to write to the formatted database file the flow variable at the current - ! time-step, t_step. The local process(es) write the part of the flow variable that they handle to the formatted database - ! slave file. The root process, on the other hand, will also take care of connecting all of the flow variable data in the - ! formatted database master file. In the Silo-HDF5 database format, the extents of each local process flow variable are also - ! written to the master file. Note that in Binary format, no master file is maintained in multidimensions. Finally note that - ! in 1D, grid data is also written within this subroutine for Silo-HDF5 database format since curve and not the - ! quadrilateral variable objects are used, see description of s_write_grid_to_formatted_database_file for more details on - ! this topic. - - ! Name of the flow variable, which will be written to the formatted database file at the current time-step, t_step character(LEN=*), intent(in) :: varname + integer, intent(in) :: t_step - ! Time-step that is currently being post-processed - integer, intent(in) :: t_step - - ! Bookkeeping variables storing the name and type of flow variable that is about to be handled by the local processor(s). - ! Note that due to an internal NAG Fortran compiler problem, these variables could not be allocated dynamically. + ! NAG compiler requires these to be statically sized character(LEN=4*name_len), dimension(num_procs) :: varnames integer, dimension(num_procs) :: vartypes - - ! Generic loop iterator - integer :: i, j, k - integer :: ierr !< Generic flag used to identify and report database errors - ! Silo-HDF5 Database Format + integer :: i, j, k + integer :: ierr if (format == 1) then ! Determining the extents of the flow variable on each local process and gathering all this information on root process @@ -699,7 +595,6 @@ contains data_extents(:, 0) = (/minval(q_sf), maxval(q_sf)/) end if - ! Next, the root process proceeds to write the gathered flow variable data extents to formatted database master file. if (proc_rank == 0) then do i = 1, num_procs write (varnames(i), '(A,I0,A,I0,A)') '../p', i - 1, '/', t_step, '.silo:' // trim(varname) @@ -716,8 +611,6 @@ contains err = DBFREEOPTLIST(optlist) end if - ! Finally, each of the local processor(s) proceeds to write the flow variable data that it is responsible for to the - ! formatted database slave file. if (wp == dp) then if (precision == 1) then do i = -offset_x%beg, m + offset_x%end @@ -785,10 +678,6 @@ contains end if end if #:endfor - - ! END: Silo-HDF5 Database Format - - ! Binary Database Format else ! Writing the name of the flow variable and its data, associated with the local processor, to the formatted database ! slave file @@ -836,7 +725,7 @@ contains logical :: lg_bub_file, file_exist integer, dimension(2) :: gsizes, lsizes, start_idx_part integer :: ifile - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr real(wp) :: file_time, file_dt integer :: file_num_procs, file_tot_part, tot_part integer :: i @@ -1191,7 +1080,7 @@ contains character(len=64), dimension(num_procs) :: var_names integer, dimension(num_procs) :: var_types real(wp) :: dummy_data - integer :: ierr !< Generic flag used to identify and report database errors + integer :: ierr integer :: i dummy_data = 0._wp @@ -1281,8 +1170,8 @@ contains impure subroutine s_write_intf_data_file(q_prim_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer :: i, j, k, l, cent !< Generic loop iterators - integer :: counter, root !< number of data points extracted to fit shape to SH perturbations + integer :: i, j, k, l, cent + integer :: counter, root !< number of data points extracted to fit shape to SH perturbations real(wp), allocatable :: x_td(:), y_td(:), x_d1(:), y_d1(:), y_d(:), x_d(:) real(wp) :: axp, axm, ayp, aym, tgp, euc_d, thres, maxalph_loc, maxalph_glb @@ -1459,20 +1348,11 @@ contains !> @brief Close the formatted database slave file and, for the root process, the master file. impure subroutine s_close_formatted_database_file() - ! Description: The purpose of this subroutine is to close any formatted database file(s) that may be opened at the time-step - ! that is currently being post-processed. The root process must typically close two files, one associated with the local - ! sub-domain and the other with the entire domain. The non- root process(es) must close one file, which is associated with - ! the local sub-domain. Note that for the Binary data- base format and multidimensional data, the root process only has to - ! close the file associated with the local sub- domain, because one associated with the entire domain is not generated. - - integer :: ierr !< Generic flag used to identify and report database errors - ! Silo-HDF5 database format + integer :: ierr if (format == 1) then ierr = DBCLOSE(dbfile) if (proc_rank == 0) ierr = DBCLOSE(dbroot) - - ! Binary database format else close (dbfile) if (n == 0 .and. proc_rank == 0) close (dbroot) @@ -1497,10 +1377,6 @@ contains !> @brief Deallocate module arrays and release all data-output resources. impure subroutine s_finalize_data_output_module() - ! Description: Deallocation procedures for the module - - ! Deallocating the generic storage employed for the flow variable(s) that were written to the formatted database file(s). - ! Note that the root variable is only deallocated in the case of a 1D computation. deallocate (q_sf) if (n == 0) deallocate (q_root_sf) if (grid_geometry == 3) then diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index e7efa5e99f..54f66e856d 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -6,10 +6,10 @@ module m_derived_variables - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_helper_basic use m_variables_conversion implicit none @@ -49,22 +49,18 @@ contains ! Allocate FD coefficients (up to 4th order; higher orders need extension) - ! Allocating centered finite-difference coefficients in x-direction 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)) end if - ! Allocating centered finite-difference coefficients in y-direction 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)) end if - ! Allocating centered finite-difference coefficients in z-direction 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)) end if - ! Set flg=1 if 3D, else 0 if (p > 0) then flg = 1 else @@ -81,8 +77,7 @@ contains real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - integer :: i, j, k !< Generic loop iterators - ! Computing specific heat ratio from specific heat ratio function + integer :: i, j, k do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end @@ -102,9 +97,7 @@ contains real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - integer :: i, j, k !< Generic loop iterators - ! Calculating the values of the liquid stiffness from those of the specific heat ratio function and the liquid stiffness - ! function + integer :: i, j, k do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end @@ -127,15 +120,12 @@ contains real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - integer :: i, j, k !< Generic loop iterators - ! Fluid bulk modulus for alternate sound speed + integer :: i, j, k real(wp) :: blkmod1, blkmod2 - ! Compute speed of sound from pressure, density, gamma, liquid stiffness do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end do i = -offset_x%beg, m + offset_x%end - ! Compute mixture sound speed if (alt_soundspeed .neqv. .true.) then q_sf(i, j, k) = (((gamma_sf(i, j, k) + 1._wp)*q_prim_vf(E_idx)%sf(i, j, k) + pi_inf_sf(i, j, & & k))/(gamma_sf(i, j, k)*rho_sf(i, j, k))) @@ -171,8 +161,8 @@ contains real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - real(wp) :: top, bottom, slope !< Flux limiter calcs - integer :: j, k, l !< Generic loop iterators + real(wp) :: top, bottom, slope + integer :: j, k, l do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end @@ -213,7 +203,6 @@ contains slope = (top*bottom)/(bottom**2._wp + 1.e-16_wp) end if - ! Flux limiter function if (flux_lim == 1) then ! MINMOD (MM) q_sf(j, k, l) = max(0._wp, min(1._wp, slope)) else if (flux_lim == 2) then ! MUSCL (MC) @@ -237,7 +226,7 @@ contains !> Computes the solution to the linear system Ax=b w/ sol = x !! @param A Input matrix - !! @param b right-hane-side + !! @param b right-hand-side !! @param sol Solution !! @param ndim Problem size subroutine s_solve_linear_system(A, b, sol, ndim) @@ -251,10 +240,9 @@ contains integer :: i, j, k - ! Solve linear system using own linear solver (Thomson/Darter/Comet/Stampede) Forward elimination + ! Forward elimination with partial pivoting do i = 1, ndim - ! Pivoting j = i - 1 + maxloc(abs(A(i:ndim, i)), 1) sol = A(i,:) A(i,:) = A(j,:) @@ -262,7 +250,6 @@ contains sol(1) = b(i) b(i) = b(j) b(j) = sol(1) - ! Elimination b(i) = b(i)/A(i, i) A(i,:) = A(i,:)/A(i, i) do k = i + 1, ndim @@ -271,7 +258,6 @@ contains end do end do - ! Backward substitution do i = ndim, 1, -1 sol(i) = b(i) do k = i + 1, ndim @@ -295,8 +281,7 @@ contains real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - integer :: j, k, l, r !< Generic loop iterators - ! Computing the vorticity component in the x-coordinate direction + integer :: j, k, l, r if (i == 1) then do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end @@ -316,8 +301,6 @@ contains end do end do end do - - ! Computing the vorticity component in the y-coordinate direction else if (i == 2) then do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end @@ -336,8 +319,6 @@ contains end do end do end do - - ! Computing the vorticity component in the z-coordinate direction else do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end @@ -368,7 +349,7 @@ contains real(wp), dimension(1:3, 1:3) :: q_jacobian_sf, S, S2, O, O2 real(wp) :: trS, Q, IIS - integer :: j, k, l, r, jj, kk !< Generic loop iterators + integer :: j, k, l, r, jj, kk do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end @@ -397,7 +378,6 @@ contains end do end do - ! Compute S2 = S*S' do jj = 1, 3 do kk = 1, 3 O2(jj, kk) = O(jj, 1)*O(kk, 1) + O(jj, 2)*O(kk, 2) + O(jj, 3)*O(kk, 3) @@ -405,7 +385,6 @@ contains end do end do - ! Compute Q Q = 0.5_wp*((O2(1, 1) + O2(2, 2) + O2(3, 3)) - (S2(1, 1) + S2(2, 2) + S2(3, 3))) trS = S(1, 1) + S(2, 2) + S(3, 3) IIS = 0.5_wp*((S(1, 1) + S(2, 2) + S(3, 3))**2 - (S2(1, 1) + S2(2, 2) + S2(3, 3))) @@ -431,20 +410,20 @@ contains !> Liutex rigid rotation axis real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, nm), & & intent(out) :: liutex_axis - character, parameter :: ivl = 'N' !< compute left eigenvectors - character, parameter :: ivr = 'V' !< compute right eigenvectors - real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor - real(wp), dimension(nm) :: lr, li !< real and imaginary parts of eigenvalues - real(wp), dimension(nm, nm) :: vl, vr !< left and right eigenvectors - integer, parameter :: lwork = 4*nm !< size of work array (4*nm recommended) - real(wp), dimension(lwork) :: work !< work array + character, parameter :: ivl = 'N' !< compute left eigenvectors + character, parameter :: ivr = 'V' !< compute right eigenvectors + real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor + real(wp), dimension(nm) :: lr, li !< real and imaginary parts of eigenvalues + real(wp), dimension(nm, nm) :: vl, vr !< left and right eigenvectors + integer, parameter :: lwork = 4*nm !< size of work array (4*nm recommended) + real(wp), dimension(lwork) :: work !< work array integer :: info - real(wp), dimension(nm) :: eigvec !< real eigenvector - real(wp) :: eigvec_mag !< magnitude of real eigenvector - real(wp) :: omega_proj !< projection of vorticity on real eigenvector - real(wp) :: lci !< imaginary part of complex eigenvalue + real(wp), dimension(nm) :: eigvec !< real eigenvector + real(wp) :: eigvec_mag !< magnitude of real eigenvector + real(wp) :: omega_proj !< projection of vorticity on real eigenvector + real(wp) :: lci !< imaginary part of complex eigenvalue real(wp) :: alpha - integer :: j, k, l, r, i !< Generic loop iterators + integer :: j, k, l, r, i integer :: idx do l = -offset_z%beg, p + offset_z%end @@ -535,10 +514,8 @@ contains !! sub-domain. The first position in the variable contains the maximum value and the second contains the rank of the !! processor on which it occurred. real(wp), dimension(2) :: gm_rho_max - integer :: i, j, k, l !< Generic loop iterators - ! Computing Gradient Magnitude of Density + integer :: i, j, k, l - ! Contributions from the x- and y-coordinate directions do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end @@ -555,7 +532,6 @@ contains end do end do - ! Contribution from the z-coordinate direction if (p > 0) then do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end @@ -576,17 +552,12 @@ contains end do end if - ! Finalize Schlieren: take sqrt of accumulated dot product gm_rho_sf = sqrt(gm_rho_sf) - ! Find local max of density gradient magnitude with processor rank gm_rho_max = (/maxval(gm_rho_sf), real(proc_rank, wp)/) - ! Compute global max density gradient across all processors if (num_procs > 1) call s_mpi_reduce_maxloc(gm_rho_max) - ! Computing Numerical Schlieren Function - ! The form of the numerical Schlieren function depends on the choice of the multicomponent flow model. For the gamma/pi_inf ! model, the exponential of the negative, normalized, gradient magnitude of the density is computed. For the volume fraction ! model, the amplitude of the exponential's inside is also modulated with respect to the identity of the fluid in which the diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 01380592b3..e7cb2d8461 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -8,19 +8,17 @@ module m_start_up - ! Dependencies - use, intrinsic :: iso_c_binding - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_mpi_common !< Common MPI subroutines - use m_boundary_common !< Common boundary conditions subroutines - use m_variables_conversion !< Subroutines to change the state variables from one form to another - use m_data_input !< Procedures reading raw simulation data to fill the conservative, primitive and grid variables - use m_data_output !< Procedures that write the grid and chosen flow variable(s) to the formatted database file(s) - use m_derived_variables !< Procedures used to compute quantities derived from the conservative and primitive variables + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_mpi_common + use m_boundary_common + use m_variables_conversion + use m_data_input + use m_data_output + use m_derived_variables use m_helper use m_compile_specific use m_checker_common @@ -30,7 +28,7 @@ module m_start_up use m_chemistry #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi #endif implicit none @@ -56,15 +54,10 @@ contains !! user provided inputs impure subroutine s_read_input_file - character(LEN=name_len) :: file_loc !< Generic string used to store the address of a particular file - !> Generic logical used for the purpose of asserting whether a file is or is not present in the designated location - logical :: file_check - integer :: iostatus - !! Integer to check iostat of file read - - character(len=1000) :: line - - ! Namelist for all of the parameters to be inputted by the user + character(LEN=name_len) :: file_loc + logical :: file_check + integer :: iostatus + character(len=1000) :: line namelist /user_inputs/ case_dir, m, n, p, t_step_start, t_step_stop, t_step_save, model_eqns, num_fluids, mpp_lim, & & weno_order, bc_x, bc_y, bc_z, fluid_pp, bub_pp, format, precision, output_partial_domain, x_output, y_output, & @@ -79,11 +72,9 @@ contains & lag_pos_prev_wrt, lag_vel_wrt, lag_rad_wrt, lag_rvel_wrt, lag_r0_wrt, lag_rmax_wrt, lag_rmin_wrt, lag_dphidt_wrt, & & lag_pres_wrt, lag_mv_wrt, lag_mg_wrt, lag_betaT_wrt, lag_betaC_wrt, alpha_rho_e_wrt, ib_state_wrt - ! Inquiring the status of the post_process.inp file file_loc = 'post_process.inp' inquire (FILE=trim(file_loc), EXIST=file_check) - ! Checking whether the input file is there. If it is, the input file is read. If not, the program is terminated. if (file_check) then open (1, FILE=trim(file_loc), form='formatted', STATUS='old', ACTION='read') read (1, NML=user_inputs, iostat=iostatus) @@ -105,7 +96,6 @@ contains p = int((p + 1)/3) - 1 end if - ! Store m,n,p into global m,n,p m_glb = m n_glb = n p_glb = p @@ -127,9 +117,8 @@ contains !! the combination of these choices results into a valid configuration for the post-process impure subroutine s_check_input_file - character(LEN=len_trim(case_dir)) :: file_loc !< Generic string used to store the address of a particular file - logical :: dir_check !< Logical variable used to test the existence of folders - ! Checking the existence of the case folder + character(LEN=len_trim(case_dir)) :: file_loc + logical :: dir_check case_dir = adjustl(case_dir) @@ -137,7 +126,6 @@ contains call my_inquire(file_loc, dir_check) - ! Constraint on the location of the case directory if (dir_check .neqv. .true.) then call s_mpi_abort('Unsupported choice for the value of ' // 'case_dir. Exiting.') end if @@ -161,19 +149,15 @@ contains end if end if - ! Populating the grid and conservative variables call s_read_data_files(t_step) - ! Populating the buffer regions of the grid and conservative variables if (buff_size > 0) then call s_populate_grid_variables_buffers() call s_populate_variables_buffers(bc_type, q_cons_vf) end if - ! Initialize the Temperature cache. if (chemistry) call s_compute_q_T_sf(q_T_sf, q_cons_vf, idwbuff) - ! Converting the conservative variables to the primitive ones call s_convert_conservative_to_primitive_variables(q_cons_vf, q_T_sf, q_prim_vf, idwbuff) end subroutine s_perform_time_step @@ -213,7 +197,6 @@ contains z_end = offset_z%end + p end if - ! Opening a new formatted database file call s_open_formatted_database_file(t_step) if (sim_data .and. proc_rank == 0) then @@ -226,25 +209,20 @@ contains call s_write_energy_data_file(q_prim_vf, q_cons_vf) end if - ! Adding the grid to the formatted database file call s_write_grid_to_formatted_database_file(t_step) - ! Computing centered finite-difference coefficients in x-direction 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) end if - ! Computing centered finite-difference coefficients in y-direction 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) end if - ! Computing centered finite-difference coefficients in z-direction 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) end if - ! Adding the partial densities to the formatted database file if ((model_eqns == 2) .or. (model_eqns == 3) .or. (model_eqns == 4)) then do i = 1, num_fluids if (alpha_rho_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then @@ -261,7 +239,6 @@ contains end do end if - ! Adding the density to the formatted database file if ((rho_wrt .or. (model_eqns == 1 .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) write (varname, '(A)') 'rho' @@ -287,7 +264,6 @@ contains varname(:) = ' ' end if - ! Adding the momentum to the formatted database file do i = 1, E_idx - mom_idx%beg if (mom_wrt(i) .or. cons_vars_wrt) then q_sf(:,:,:) = q_cons_vf(i + cont_idx%end)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) @@ -298,7 +274,6 @@ contains end if end do - ! Adding the velocity to the formatted database file do i = 1, E_idx - mom_idx%beg if (vel_wrt(i) .or. prim_vars_wrt) then q_sf(:,:,:) = q_prim_vf(i + cont_idx%end)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) @@ -309,7 +284,6 @@ contains end if end do - ! Adding the species' concentrations to the formatted database file if (chemistry) then do i = 1, num_species if (chem_wrt_Y(i) .or. prim_vars_wrt) then @@ -330,7 +304,6 @@ contains end if end if - ! Adding the flux limiter function to the formatted database file do i = 1, E_idx - mom_idx%beg if (flux_wrt(i)) then call s_derive_flux_limiter(i, q_prim_vf, q_sf) @@ -342,7 +315,6 @@ contains end if end do - ! Adding the energy to the formatted database file if (E_wrt .or. cons_vars_wrt) then q_sf(:,:,:) = q_cons_vf(E_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) write (varname, '(A)') 'E' @@ -351,7 +323,6 @@ contains varname(:) = ' ' end if - ! Adding the individual energies to the formatted database file if (model_eqns == 3) then do i = 1, num_fluids if (alpha_rho_e_wrt(i) .or. cons_vars_wrt) then @@ -364,7 +335,6 @@ contains end do end if - ! Adding Energy cascade FFT if (fft_wrt) then do l = 0, p do k = 0, n @@ -470,7 +440,6 @@ contains end do end if - ! Adding the magnetic field to the formatted database file if (mhd .and. prim_vars_wrt) then do i = B_idx%beg, B_idx%end q_sf(:,:,:) = q_prim_vf(i)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) @@ -498,7 +467,6 @@ contains end do end if - ! Adding the elastic shear stresses to the formatted database file if (elasticity) then do i = 1, stress_idx%end - stress_idx%beg + 1 if (prim_vars_wrt) then @@ -537,7 +505,6 @@ contains varname(:) = ' ' end if - ! Adding the pressure to the formatted database file if (pres_wrt .or. prim_vars_wrt) then q_sf(:,:,:) = q_prim_vf(E_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) write (varname, '(A)') 'pres' @@ -546,7 +513,6 @@ contains varname(:) = ' ' end if - ! Adding the volume fraction(s) to the formatted database file if (((model_eqns == 2) .and. (bubbles_euler .neqv. .true.)) .or. (model_eqns == 3)) then do i = 1, num_fluids - 1 if (alpha_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then @@ -580,7 +546,6 @@ contains end if end if - ! Adding specific heat ratio function to formatted database file if (gamma_wrt .or. (model_eqns == 1 .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) write (varname, '(A)') 'gamma' @@ -589,7 +554,6 @@ contains varname(:) = ' ' end if - ! Adding the specific heat ratio to the formatted database file if (heat_ratio_wrt) then call s_derive_specific_heat_ratio(q_sf) @@ -599,7 +563,6 @@ contains varname(:) = ' ' end if - ! Adding liquid stiffness function to formatted database file if (pi_inf_wrt .or. (model_eqns == 1 .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) write (varname, '(A)') 'pi_inf' @@ -608,7 +571,6 @@ contains varname(:) = ' ' end if - ! Adding the liquid stiffness to the formatted database file if (pres_inf_wrt) then call s_derive_liquid_stiffness(q_sf) @@ -618,7 +580,6 @@ contains varname(:) = ' ' end if - ! Adding the sound speed to the formatted database file if (c_wrt) then do k = -offset_z%beg, p + offset_z%end do j = -offset_y%beg, n + offset_y%end @@ -645,7 +606,6 @@ contains varname(:) = ' ' end if - ! Adding the vorticity to the formatted database file do i = 1, 3 if (omega_wrt(i)) then call s_derive_vorticity_component(i, q_prim_vf, q_sf) @@ -664,7 +624,6 @@ contains call s_write_variable_to_formatted_database_file(varname, t_step) end if - ! Adding Q_M to the formatted database file if (p > 0 .and. qm_wrt) then call s_derive_qm(q_prim_vf, q_sf) @@ -674,12 +633,9 @@ contains varname(:) = ' ' end if - ! Adding Liutex magnitude to the formatted database file if (liutex_wrt) then - ! Compute Liutex vector and its magnitude call s_derive_liutex(q_prim_vf, liutex_mag, liutex_axis) - ! Liutex magnitude q_sf = liutex_mag write (varname, '(A)') 'liutex_mag' @@ -687,7 +643,6 @@ contains varname(:) = ' ' - ! Liutex axis do i = 1, 3 q_sf = liutex_axis(:,:,:, i) @@ -698,7 +653,6 @@ contains end do end if - ! Adding numerical Schlieren function to formatted database file if (schlieren_wrt) then call s_derive_numerical_schlieren_function(q_cons_vf, q_sf) @@ -708,7 +662,6 @@ contains varname(:) = ' ' end if - ! Adding the color function to formatted database file if (cf_wrt) then q_sf(:,:,:) = q_cons_vf(c_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) write (varname, '(A,I0)') 'color_function' @@ -716,7 +669,6 @@ contains varname(:) = ' ' end if - ! Adding the volume fraction(s) to the formatted database file if (bubbles_euler) then do i = adv_idx%beg, adv_idx%end q_sf(:,:,:) = q_cons_vf(i)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) @@ -726,7 +678,6 @@ contains end do end if - ! Adding the bubble variables to the formatted database file if (bubbles_euler) then ! nR do i = 1, nb @@ -770,7 +721,6 @@ contains end if end if - ! Adding the lagrangian subgrid variables to the formatted database file 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, & @@ -788,7 +738,6 @@ contains call s_close_energy_data_file() end if - ! Closing the formatted database file call s_close_formatted_database_file() end subroutine s_save_data @@ -881,7 +830,6 @@ contains !> @brief Initialize all post-process sub-modules, set up I/O pointers, and prepare FFTW plans and MPI communicators. impure subroutine s_initialize_modules - ! Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the modules integer :: size_n(1), inembed(1), onembed(1) call s_initialize_global_parameters_module() @@ -898,7 +846,6 @@ contains call s_initialize_derived_variables_module() call s_initialize_data_output_module() - ! Associate pointers for serial or parallel I/O if (parallel_io .neqv. .true.) then s_read_data_files => s_read_serial_data_files else @@ -1041,12 +988,8 @@ contains num_dims = 1 + min(1, n) + min(1, p) - ! Initialization of the MPI environment call s_mpi_initialize() - ! Processor with rank 0 assigns default user input values prior to reading those in from the input file. Next, the user - ! inputs are read in and their consistency is checked. The detection of any inconsistencies automatically leads to the - ! termination of the post-process. if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() @@ -1055,8 +998,6 @@ contains print '(" Post-processing a ", I0, "x", I0, "x", I0, " case on ", I0, " rank(s)")', m, n, p, num_procs end if - ! Broadcasting the user inputs to all of the processors and performing the parallel computational domain decomposition. - ! Neither procedure has to be carried out if the post-process is in fact not truly executed in parallel. call s_mpi_bcast_user_inputs() call s_initialize_parallel_io() call s_mpi_decompose_computational_domain() @@ -1067,7 +1008,6 @@ contains !> @brief Destroy FFTW plans, free MPI communicators, and finalize all post-process sub-modules. impure subroutine s_finalize_modules - ! Disassociate pointers for serial and parallel I/O s_read_data_files => null() ! if (sim_data .and. proc_rank == 0) then call s_close_intf_data_file() call s_close_energy_data_file() end if @@ -1094,7 +1034,6 @@ contains end if #endif - ! Deallocation procedures for the modules call s_finalize_data_output_module() call s_finalize_derived_variables_module() call s_finalize_data_input_module() @@ -1105,7 +1044,6 @@ contains end if call s_finalize_global_parameters_module() - ! Finalizing the MPI environment call s_mpi_finalize() end subroutine s_finalize_modules diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index 8c22bed7f5..57016fd0fa 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -8,9 +8,9 @@ !> @brief Assigns initial primitive variables to computational cells based on patch geometry module m_assign_variables - use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters for the code - use m_variables_conversion ! Subroutines to change the state variables from + use m_derived_types + use m_global_parameters + use m_variables_conversion use m_helper_basic !< Functions to compare floating point numbers use m_thermochem, only: num_species, gas_constant, get_mixture_molecular_weight @@ -104,39 +104,30 @@ contains real(wp) :: Ys(1:num_species) integer :: smooth_patch_id - integer :: i !< generic loop operator - ! Assigning the mixture primitive variables of a uniform state patch + integer :: i - ! Transferring the identity of the smoothing patch smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id - ! Density q_prim_vf(1)%sf(j, k, l) = eta*patch_icpp(patch_id)%rho + (1._wp - eta)*patch_icpp(smooth_patch_id)%rho - ! Velocity do i = 1, E_idx - mom_idx%beg q_prim_vf(i + 1)%sf(j, k, l) = 1._wp/q_prim_vf(1)%sf(j, k, & & l)*(eta*patch_icpp(patch_id)%rho*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*patch_icpp(smooth_patch_id) & & %rho*patch_icpp(smooth_patch_id)%vel(i)) end do - ! Specific heat ratio function q_prim_vf(gamma_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%gamma + (1._wp - eta)*patch_icpp(smooth_patch_id)%gamma - ! Pressure q_prim_vf(E_idx)%sf(j, k, l) = 1._wp/q_prim_vf(gamma_idx)%sf(j, k, & & l)*(eta*patch_icpp(patch_id)%gamma*patch_icpp(patch_id)%pres + (1._wp - eta)*patch_icpp(smooth_patch_id) & & %gamma*patch_icpp(smooth_patch_id)%pres) - ! Liquid stiffness function q_prim_vf(pi_inf_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%pi_inf + (1._wp - eta)*patch_icpp(smooth_patch_id)%pi_inf - ! Species Concentrations if (chemistry) then block real(wp) :: sum, term - ! Accumulating the species concentrations sum = 0._wp do i = 1, num_species term = eta*patch_icpp(patch_id)%Y(i) + (1._wp - eta)*patch_icpp(smooth_patch_id)%Y(i) @@ -146,7 +137,6 @@ contains sum = max(sum, verysmall) - ! Normalizing the species concentrations do i = 1, num_species q_prim_vf(chemxb + i - 1)%sf(j, k, l) = q_prim_vf(chemxb + i - 1)%sf(j, k, l)/sum Ys(i) = q_prim_vf(chemxb + i - 1)%sf(j, k, l) @@ -154,7 +144,6 @@ contains end block end if - ! Updating the patch identities bookkeeping variable if (1._wp - eta < 1.e-16_wp) patch_id_fp(j, k, l) = patch_id end subroutine s_assign_patch_mixture_primitive_variables @@ -273,13 +262,11 @@ contains real(wp), dimension(3) :: xi_cart real(wp) :: Ys(1:num_species) real(stp), dimension(sys_size) :: orig_prim_vf !< Vector to hold original values of cell for smoothing purposes - integer :: i !< Generic loop iterator + integer :: i integer :: smooth_patch_id - ! Transferring the identity of the smoothing patch smooth_patch_id = patch_icpp(patch_id)%smooth_patch_id - ! Transferring original primitive variables do i = 1, sys_size orig_prim_vf(i) = q_prim_vf(i)%sf(j, k, l) end do @@ -296,13 +283,9 @@ contains end do end if - ! Computing Mixture Variables from Original Primitive Variables call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, orig_rho, orig_gamma, orig_pi_inf, orig_qv) - ! Computing Mixture Variables of Current Patch - if (.not. igr .or. num_fluids > 1) then - ! Volume fraction(s) do i = adv_idx%beg, adv_idx%end q_prim_vf(i)%sf(j, k, l) = patch_icpp(patch_id)%alpha(i - E_idx) end do @@ -320,28 +303,22 @@ contains end do end if - ! Partial densities if (model_eqns /= 4) then do i = 1, cont_idx%end q_prim_vf(i)%sf(j, k, l) = patch_icpp(patch_id)%alpha_rho(i) end do end if - ! Density and the specific heat ratio and liquid stiffness functions call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, patch_icpp(patch_id)%rho, patch_icpp(patch_id)%gamma, & & patch_icpp(patch_id)%pi_inf, patch_icpp(patch_id)%qv) - ! Computing Mixture Variables of Smoothing Patch - if (model_eqns /= 4) then - ! Partial densities do i = 1, cont_idx%end q_prim_vf(i)%sf(j, k, l) = patch_icpp(smooth_patch_id)%alpha_rho(i) end do end if if (.not. igr .or. num_fluids > 1) then - ! Volume fraction(s) do i = adv_idx%beg, adv_idx%end q_prim_vf(i)%sf(j, k, l) = patch_icpp(smooth_patch_id)%alpha(i - E_idx) end do @@ -359,7 +336,6 @@ contains end do end if - ! Bubbles euler variables if (bubbles_euler) then do i = 1, nb muR = R0(i)*patch_icpp(smooth_patch_id)%r0/R0ref @@ -401,16 +377,13 @@ contains end if end if - ! Density and the specific heat ratio and liquid stiffness functions call s_convert_species_to_mixture_variables( & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, patch_icpp(smooth_patch_id)%rho, & & patch_icpp(smooth_patch_id)%gamma, patch_icpp(smooth_patch_id)%pi_inf, & & patch_icpp(smooth_patch_id)%qv) - ! Pressure q_prim_vf(E_idx)%sf(j, k, l) = (eta*patch_icpp(patch_id)%pres + (1._wp - eta)*orig_prim_vf(E_idx)) if (.not. igr .or. num_fluids > 1) then - ! Volume fractions \alpha do i = adv_idx%beg, adv_idx%end q_prim_vf(i)%sf(j, k, l) = eta*patch_icpp(patch_id)%alpha(i - E_idx) + (1._wp - eta)*orig_prim_vf(i) end do @@ -427,7 +400,6 @@ contains end if end if - ! Elastic Shear Stress if (elasticity) then do i = 1, (stress_idx%end - stress_idx%beg) + 1 q_prim_vf(i + stress_idx%beg - 1)%sf(j, k, & @@ -435,7 +407,6 @@ contains end do end if - ! Elastic Shear Stress if (hyperelasticity) then if (pre_stress) then ! pre stressed initial condition in spatial domain rcoord = sqrt((x_cc(j)**2 + y_cc(k)**2 + z_cc(l)**2)) @@ -470,7 +441,6 @@ contains end do end if - ! Partial densities \alpha \rho if (model_eqns /= 4) then ! mixture density is an input do i = 1, cont_idx%end @@ -487,22 +457,17 @@ contains & l) + pi_inf)/(pref + pi_inf))**(1/lit_gamma))*rhoref*(1 - q_prim_vf(alf_idx)%sf(j, k, l)) end if - ! Density and the specific heat ratio and liquid stiffness functions call s_convert_species_to_mixture_variables(q_prim_vf, - ! j, k, l, & call s_convert_to_mixture_variables(q_prim_vf, j, k, l, rho, gamma, pi_inf, qv) - ! Velocity do i = 1, E_idx - mom_idx%beg q_prim_vf(i + cont_idx%end)%sf(j, k, & & l) = (eta*patch_icpp(patch_id)%vel(i) + (1._wp - eta)*orig_prim_vf(i + cont_idx%end)) end do - ! Species Concentrations if (chemistry) then block real(wp) :: sum, term - ! Accumulating the species concentrations sum = 0._wp do i = 1, num_species term = eta*patch_icpp(patch_id)%Y(i) + (1._wp - eta)*patch_icpp(smooth_patch_id)%Y(i) @@ -514,7 +479,6 @@ contains sum = 1._wp end if - ! Normalizing the species concentrations do i = 1, num_species q_prim_vf(chemxb + i - 1)%sf(j, k, l) = q_prim_vf(chemxb + i - 1)%sf(j, k, l)/sum Ys(i) = q_prim_vf(chemxb + i - 1)%sf(j, k, l) @@ -536,7 +500,6 @@ contains end do end if - ! Smoothed bubble variables if (bubbles_euler) then do i = 1, nb muR = R0(i)*patch_icpp(patch_id)%r0/R0ref @@ -607,7 +570,6 @@ contains q_prim_vf(c_idx)%sf(j, k, l) = eta*patch_icpp(patch_id)%cf_val + (1._wp - eta)*orig_prim_vf(c_idx) end if - ! Updating the patch identities bookkeeping variable if (1._wp - eta < 1.e-16_wp) patch_id_fp(j, k, l) = patch_id ! if (j == 1) then print *, (q_prim_vf(bub_idx%rs(i))%sf(j, k, l), i = 1, nb) print *, (q_prim_vf(bub_idx%fullmom(i, 1, @@ -619,7 +581,6 @@ contains !> @brief Nullifies the patch primitive variable assignment procedure pointer. impure subroutine s_finalize_assign_variables_module - ! Nullify primitive variable assignment procedure pointer s_assign_patch_primitive_variables => null() end subroutine s_finalize_assign_variables_module diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index eafe90b2ad..bfb2884dd5 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -5,12 +5,12 @@ !> @brief Writes grid and initial condition data to serial or parallel output files module m_data_output - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code + use m_derived_types + use m_global_parameters use m_helper - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi #endif use m_compile_specific @@ -38,7 +38,6 @@ module m_data_output import :: scalar_field, integer_field, sys_size, m, n, p, pres_field, num_dims - ! Conservative variables type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type @@ -58,25 +57,22 @@ contains !! @param bc_type Boundary condition types impure subroutine s_write_serial_data_files(q_cons_vf, q_prim_vf, bc_type) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf - - ! BC types + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type - logical :: file_exist !< checks if file exists + logical :: file_exist character(LEN=15) :: FMT character(LEN=3) :: status - !> Used to store the number, in character form, of the currently manipulated conservative variable data file - character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num - character(LEN=len_trim(t_step_dir) + name_len) :: file_loc !< Generic string used to store the address of a particular file - integer :: i, j, k, l, r, c !< Generic loop iterator - integer :: t_step - real(wp), dimension(nb) :: nRtmp !< Temporary bubble concentration - real(wp) :: nbub !< Temporary bubble number density - real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params - real(wp) :: rho !< Temporary density - real(wp) :: pres, T !< Temporary pressure - real(wp) :: rhoYks(1:num_species) !< Temporary species mass fractions - real(wp) :: pres_mag + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num + character(LEN=len_trim(t_step_dir) + name_len) :: file_loc + integer :: i, j, k, l, r, c + integer :: t_step + real(wp), dimension(nb) :: nRtmp + real(wp) :: nbub + real(wp) :: gamma, lit_gamma, pi_inf, qv + real(wp) :: rho + real(wp) :: pres, T + real(wp) :: rhoYks(1:num_species) + real(wp) :: pres_mag pres_mag = 0._wp @@ -84,8 +80,6 @@ contains t_step = 0 - ! Outputting the Locations of the Cell-boundaries - if (old_grid) then status = 'old' else @@ -100,21 +94,17 @@ contains end if end if - ! x-coordinate direction file_loc = trim(t_step_dir) // '/x_cb.dat' open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) write (1) x_cb(-1:m) close (1) - ! y- and z-coordinate directions if (n > 0) then - ! y-coordinate direction file_loc = trim(t_step_dir) // '/y_cb.dat' open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) write (1) y_cb(-1:n) close (1) - ! z-coordinate direction if (p > 0) then file_loc = trim(t_step_dir) // '/z_cb.dat' open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) @@ -123,7 +113,6 @@ contains end if end if - ! Outputting Conservative Variables do i = 1, sys_size write (file_num, '(I0)') i file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' @@ -132,7 +121,6 @@ contains close (1) end do - ! Outputting pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode @@ -175,7 +163,6 @@ contains if (cfl_dt) t_step = n_start - ! 1D if (n == 0 .and. p == 0) then if (model_eqns == 2) then do i = 1, sys_size @@ -291,7 +278,6 @@ contains FMT = "(3F40.14)" end if - ! 2D if ((n > 0) .and. (p == 0)) then do i = 1, sys_size write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' @@ -343,7 +329,6 @@ contains FMT = "(4F40.14)" end if - ! 3D if (p > 0) then do i = 1, sys_size write (file_loc, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' @@ -404,7 +389,6 @@ contains !! @param bc_type Boundary condition types impure subroutine s_write_parallel_data_files(q_cons_vf, q_prim_vf, bc_type) - ! Conservative variables type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type @@ -418,15 +402,11 @@ contains integer(KIND=MPI_OFFSET_KIND) :: MOK character(LEN=path_len + 2*name_len) :: file_loc logical :: file_exist, dir_check - - ! Generic loop iterators - integer :: i, j, k, l - real(wp) :: loc_violations, glb_violations - - ! Downsample variables - integer :: m_ds, n_ds, p_ds - integer :: m_glb_ds, n_glb_ds, p_glb_ds - integer :: m_glb_save, n_glb_save, p_glb_save ! Size of array being saved + integer :: i, j, k, l + real(wp) :: loc_violations, glb_violations + integer :: m_ds, n_ds, p_ds + integer :: m_glb_ds, n_glb_ds, p_glb_ds + integer :: m_glb_save, n_glb_save, p_glb_save ! Size of array being saved loc_violations = 0._wp @@ -456,14 +436,12 @@ contains call s_mpi_barrier() call DelayFileAccess(proc_rank) - ! Initialize MPI data I/O if (down_sample) then call s_initialize_mpi_data_ds(q_cons_temp) else call s_initialize_mpi_data(q_cons_vf) end if - ! Open the file to write all flow variables if (cfl_dt) then write (file_loc, '(I0,A,i7.7,A)') n_start, '_', proc_rank, '.dat' else @@ -478,13 +456,11 @@ contains call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) if (down_sample) then - ! Size of local arrays data_size = (m_ds + 3)*(n_ds + 3)*(p_ds + 3) m_glb_save = m_glb_ds + 3 n_glb_save = n_glb_ds + 3 p_glb_save = p_glb_ds + 3 else - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) m_glb_save = m_glb + 1 n_glb_save = n_glb + 1 @@ -500,14 +476,12 @@ contains str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - ! Write the data for each variable if (bubbles_euler) then - do i = 1, sys_size ! adv_idx%end + do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - ! Additional variables pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) @@ -535,7 +509,6 @@ contains else call s_initialize_mpi_data(q_cons_vf) - ! Open the file to write all flow variables if (cfl_dt) then write (file_loc, '(I0,A)') n_start, '.dat' else @@ -548,7 +521,6 @@ contains end if call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) ! Resize some integers so MPI can write even the biggest files @@ -560,23 +532,19 @@ contains str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - ! Write the data for each variable if (bubbles_euler) then - do i = 1, sys_size ! adv_idx%end + do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - ! Additional variables pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) @@ -584,11 +552,9 @@ contains end do end if else - do i = 1, sys_size ! TODO: check if this is right - ! do i = 1, adv_idx%end + do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) @@ -613,22 +579,17 @@ contains !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_data_output_module - ! Generic string used to store the address of a particular file character(LEN=len_trim(case_dir) + 2*name_len) :: file_loc character(len=15) :: temp character(LEN=1), dimension(3), parameter :: coord = (/'x', 'y', 'z'/) - - ! Generic logical used to check the existence of directories - logical :: dir_check - integer :: i - integer :: m_ds, n_ds, p_ds !< down sample dimensions + logical :: dir_check + integer :: i + integer :: m_ds, n_ds, p_ds if (parallel_io .neqv. .true.) then - ! Setting the address of the time-step directory write (t_step_dir, '(A,I0,A)') '/p_all/p', proc_rank, '/0' t_step_dir = trim(case_dir) // trim(t_step_dir) - ! Remove existing time-step dir if needed (unless reading preexisting data; handled in m_start_up) if (old_grid .neqv. .true.) then file_loc = trim(t_step_dir) // '/' diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 430a193372..696901dc7b 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -5,16 +5,14 @@ !> @brief Assembles initial conditions by layering prioritized patches via constructive solid geometry module m_initial_condition - use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types + use m_global_parameters + use m_mpi_proxy use m_helper - use m_variables_conversion ! Subroutines to change the state variables from - ! one form to another - + use m_variables_conversion use m_icpp_patches use m_assign_variables - use m_perturbation ! Subroutines to perturb initial flow fields + use m_perturbation use m_chemistry use m_boundary_conditions @@ -40,8 +38,7 @@ contains !> Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the module impure subroutine s_initialize_initial_condition_module - integer :: i, j, k, l !< generic loop iterators - ! Allocating the primitive and conservative variables + integer :: i, j, k, l allocate (q_prim_vf(1:sys_size)) allocate (q_cons_vf(1:sys_size)) @@ -55,22 +52,18 @@ contains allocate (q_T_sf%sf(0:m, 0:n, 0:p)) end if - ! Allocating the patch identities bookkeeping variable allocate (patch_id_fp(0:m, 0:n, 0:p)) if (qbmm .and. .not. polytropic) then - ! Allocate bubble pressure pb and vapor mass mv for non-polytropic qbmm at all quad nodes and R0 bins allocate (pb%sf(0:m, 0:n, 0:p, 1:nnode, 1:nb)) allocate (mv%sf(0:m, 0:n, 0:p, 1:nnode, 1:nb)) end if - ! Initialize q_cons, q_prim with sentinel values to catch IC errors do i = 1, sys_size q_cons_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) ! TODO :: remove this magic number q_prim_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) end do - ! Allocating arrays to store the bc types allocate (bc_type(1:num_dims, 1:2)) allocate (bc_type(1, 1)%sf(0:0, 0:n, 0:p)) @@ -133,9 +126,6 @@ contains integer :: i - ! Converting the conservative variables to the primitive ones given preexisting initial condition data files were read in on - ! start-up - if (old_ic) then call s_convert_conservative_to_primitive_variables(q_cons_vf, q_T_sf, q_prim_vf, idwbuff) end if @@ -150,13 +140,11 @@ contains if (simplex_perturb) call s_perturb_simplex(q_prim_vf) if (elliptic_smoothing) call s_elliptic_smoothing(q_prim_vf, bc_type) - ! Converting the primitive variables to the conservative ones call s_convert_primitive_to_conservative_variables(q_prim_vf, q_cons_vf) if (chemistry) call s_compute_T_from_primitives(q_T_sf, q_prim_vf, idwint) if (qbmm .and. .not. polytropic) then - ! Initialize pb and mv call s_initialize_mv(q_cons_vf, mv%sf) call s_initialize_pb(q_cons_vf, mv%sf, pb%sf) end if @@ -166,8 +154,7 @@ contains !> Deallocation procedures for the module impure subroutine s_finalize_initial_condition_module - integer :: i !< Generic loop iterator - ! Dellocating the primitive and conservative variables + integer :: i do i = 1, sys_size deallocate (q_prim_vf(i)%sf) @@ -181,7 +168,6 @@ contains deallocate (q_T_sf%sf) end if - ! Deallocating the patch identities bookkeeping variable deallocate (patch_id_fp) deallocate (bc_type(1, 1)%sf) diff --git a/src/pre_process/m_mpi_proxy.fpp b/src/pre_process/m_mpi_proxy.fpp index c9bb736f84..e9545ce865 100644 --- a/src/pre_process/m_mpi_proxy.fpp +++ b/src/pre_process/m_mpi_proxy.fpp @@ -6,12 +6,12 @@ module m_mpi_proxy #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi #endif use m_helper - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code + use m_derived_types + use m_global_parameters use m_mpi_common implicit none @@ -22,13 +22,9 @@ contains impure subroutine s_mpi_bcast_user_inputs #ifdef MFC_MPI - ! Generic loop iterator integer :: i, j - ! Generic flag used to identify and report MPI errors integer :: ierr - ! Logistics - call MPI_BCAST(case_dir, len(case_dir), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) #:for VAR in ['t_step_old', 't_step_start', 'm', 'n', 'p', 'm_glb', 'n_glb', 'p_glb', & diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index c439bd0d63..698fe79a37 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -5,10 +5,10 @@ !> @brief Perturbs initial mean flow fields with random noise, mixing-layer instabilities, or simplex noise module m_perturbation - use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_boundary_common ! Boundary conditions module + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_boundary_common use m_helper use m_simplex_noise use ieee_arithmetic @@ -32,7 +32,7 @@ contains impure subroutine s_perturb_sphere(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k, l !< generic loop operators + integer :: i, j, k, l real(wp) :: perturb_alpha real(wp) :: rand_real @@ -48,7 +48,6 @@ contains ! Perturb partial density fields to match perturbed volume fraction fields IF ((perturb_alpha >= 25e-2_wp) .AND. ! (perturb_alpha <= 75e-2_wp)) THEN if ((.not. f_approx_equal(perturb_alpha, 0._wp)) .and. (.not. f_approx_equal(perturb_alpha, 1._wp))) then - ! Derive new partial densities do l = 1, num_fluids q_prim_vf(l)%sf(i, j, k) = q_prim_vf(E_idx + l)%sf(i, j, k)*fluid_rho(l) end do @@ -63,13 +62,12 @@ contains impure subroutine s_perturb_surrounding_flow(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< generic loop iterators + integer :: i, j, k real(wp) :: perturb_alpha real(wp) :: rand_real call random_seed() - ! Perturb partial density or velocity of surrounding flow by some random small amount of noise do k = 0, p do j = 0, n do i = 0, m @@ -243,8 +241,6 @@ contains real(wp) :: dk, alpha, Eksum, q, uu0, phi integer :: i, j, l, r, ierr - ! Initialize parameters - dk = 1._wp/mixlayer_perturb_nk ! Compute prescribed energy spectra diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 37f6933c59..8692fb2900 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -7,23 +7,23 @@ !> @brief Reads and validates user inputs, loads existing grid/IC data, and initializes pre-process modules module m_start_up - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types + use m_global_parameters + use m_mpi_proxy use m_mpi_common - use m_variables_conversion !< Subroutines to change the state variables from one form to another - use m_grid !< Procedures to generate (non-)uniform grids - use m_initial_condition !< Procedures to generate initial condition - use m_data_output !< Procedures to write the grid data and the conservative variables to files - use m_compile_specific !< Compile-specific procedures + use m_variables_conversion + use m_grid + use m_initial_condition + use m_data_output + use m_compile_specific use m_icpp_patches use m_assign_variables - use m_phase_change !< Phase-change module - use m_helper_basic !< Functions to compare floating point numbers + use m_phase_change + use m_helper_basic use m_helper #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi #endif use m_check_patches @@ -72,15 +72,10 @@ contains !! user provided inputs impure subroutine s_read_input_file - character(LEN=name_len) :: file_loc !< Generic string used to store the address of a particular file - !> Generic logical used for the purpose of asserting whether a file is or is not present in the designated location - logical :: file_check - integer :: iostatus - !! Integer to check iostat of file read - - character(len=1000) :: line - - ! Namelist for all of the parameters to be inputted by the user + character(LEN=name_len) :: file_loc + logical :: file_check + integer :: iostatus + character(len=1000) :: line namelist /user_inputs/ case_dir, old_grid, old_ic, t_step_old, t_step_start, m, n, p, x_domain, y_domain, z_domain, & & stretch_x, stretch_y, stretch_z, a_x, a_y, a_z, x_a, y_a, z_a, x_b, y_b, z_b, model_eqns, num_fluids, mpp_lim, & @@ -94,11 +89,9 @@ contains & bubbles_lagrange, num_bc_patches, patch_bc, Bx0, relativity, cont_damage, igr, igr_order, down_sample, recon_type, & & muscl_order, hyper_cleaning, simplex_perturb, simplex_params, fft_wrt - ! Inquiring the status of the pre_process.inp file file_loc = 'pre_process.inp' inquire (FILE=trim(file_loc), EXIST=file_check) - ! Checking whether the input file is there. If it is, the input file is read. If not, the program is terminated. if (file_check) then open (1, FILE=trim(file_loc), form='formatted', STATUS='old', ACTION='read') read (1, NML=user_inputs, iostat=iostatus) @@ -112,7 +105,6 @@ contains call s_update_cell_bounds(cells_bounds, m, n, p) - ! Store m,n,p into global m,n,p m_glb = m n_glb = n p_glb = p @@ -134,9 +126,8 @@ contains !! the combination of these choices results into a valid configuration for the pre-process impure subroutine s_check_input_file - character(LEN=len_trim(case_dir)) :: file_loc !< Generic string used to store the address of a particular file - logical :: dir_check !< Logical variable used to test the existence of folders - ! Checking the existence of the case folder + character(LEN=len_trim(case_dir)) :: file_loc + logical :: dir_check case_dir = adjustl(case_dir) @@ -153,7 +144,6 @@ contains call s_check_inputs_common() call s_check_inputs() - ! Check all the patch properties call s_check_patches() if (ib) call s_check_ib_patches() @@ -164,16 +154,9 @@ contains !! necessary global computational domain parameters. impure subroutine s_read_serial_grid_data_files - ! Generic string used to store the address of a particular file character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc - - ! Logical variable used to test the existence of folders - logical :: dir_check - - ! Generic logical used for the purpose of asserting whether a file is or is not present in the designated location - logical :: file_check - - ! Setting address of the local processor rank and time-step directory + logical :: dir_check + logical :: file_check write (proc_rank_dir, '(A,I0)') '/p_all/p', proc_rank proc_rank_dir = trim(case_dir) // trim(proc_rank_dir) @@ -181,22 +164,16 @@ contains write (t_step_dir, '(A,I0)') '/', t_step_start t_step_dir = trim(proc_rank_dir) // trim(t_step_dir) - ! Inquiring as to the existence of the time-step directory file_loc = trim(t_step_dir) // '/.' call my_inquire(file_loc, dir_check) - ! If the time-step directory is missing, the pre-process exits if (dir_check .neqv. .true.) then call s_mpi_abort('Time-step folder ' // trim(t_step_dir) // ' is missing. Exiting.') end if - ! Reading the Grid Data File for the x-direction - - ! Checking whether x_cb.dat exists file_loc = trim(t_step_dir) // '/x_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) - ! If it exists, x_cb.dat is read if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) x_cb(-1:m) @@ -205,25 +182,18 @@ contains call s_mpi_abort('File x_cb.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if - ! Computing cell-center locations x_cc(0:m) = (x_cb(0:m) + x_cb(-1:(m - 1)))/2._wp - ! Computing minimum cell-width dx = minval(x_cb(0:m) - x_cb(-1:m - 1)) if (num_procs > 1) call s_mpi_reduce_min(dx) - ! Setting locations of domain bounds x_domain%beg = x_cb(-1) x_domain%end = x_cb(m) - ! Reading the Grid Data File for the y-direction - if (n > 0) then - ! Checking whether y_cb.dat exists file_loc = trim(t_step_dir) // '/y_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) - ! If it exists, y_cb.dat is read if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) y_cb(-1:n) @@ -232,24 +202,18 @@ contains call s_mpi_abort('File y_cb.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if - ! Computing cell-center locations y_cc(0:n) = (y_cb(0:n) + y_cb(-1:(n - 1)))/2._wp - ! Computing minimum cell-width dy = minval(y_cb(0:n) - y_cb(-1:n - 1)) if (num_procs > 1) call s_mpi_reduce_min(dy) - ! Setting locations of domain bounds y_domain%beg = y_cb(-1) y_domain%end = y_cb(n) - ! Reading the Grid Data File for the z-direction if (p > 0) then - ! Checking whether z_cb.dat exists file_loc = trim(t_step_dir) // '/z_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_check) - ! If it exists, z_cb.dat is read if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) z_cb(-1:p) @@ -258,14 +222,11 @@ contains call s_mpi_abort('File z_cb.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if - ! Computing cell-center locations z_cc(0:p) = (z_cb(0:p) + z_cb(-1:(p - 1)))/2._wp - ! Computing minimum cell-width dz = minval(z_cb(0:p) - z_cb(-1:p - 1)) if (num_procs > 1) call s_mpi_reduce_min(dz) - ! Setting locations of domain bounds z_domain%beg = z_cb(-1) z_domain%end = z_cb(p) end if @@ -283,21 +244,15 @@ contains !! coordinate directions and making sure that all of the cell-widths are positively valued impure subroutine s_check_grid_data_files - ! Cell-boundary Data Consistency Check in x-direction - if (any(x_cb(0:m) - x_cb(-1:m - 1) <= 0._wp)) then call s_mpi_abort('x_cb.dat in ' // trim(t_step_dir) // ' contains non-positive cell-spacings. Exiting.') end if - ! Cell-boundary Data Consistency Check in y-direction - if (n > 0) then if (any(y_cb(0:n) - y_cb(-1:n - 1) <= 0._wp)) then call s_mpi_abort('y_cb.dat in ' // trim(t_step_dir) // ' contains non-positive cell-spacings. ' // 'Exiting.') end if - ! Cell-boundary Data Consistency Check in z-direction - if (p > 0) then if (any(z_cb(0:p) - z_cb(-1:p - 1) <= 0._wp)) then call s_mpi_abort('z_cb.dat in ' // trim(t_step_dir) // ' contains non-positive cell-spacings' // ' .Exiting.') @@ -312,24 +267,17 @@ contains !! @param q_cons_vf_in Conservative variables impure subroutine s_read_serial_ic_data_files(q_cons_vf_in) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in - character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc - ! Generic string used to store the address of a particular file - - !> Used to store the variable position, in character form, of the currently manipulated conservative variable file + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in + character(LEN=len_trim(case_dir) + 3*name_len) :: file_loc character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num - !> Generic logical used for the purpose of asserting whether a file is or is not present in the designated location - logical :: file_check - integer :: i, r !< Generic loop iterator - ! Reading the Conservative Variables Data Files + logical :: file_check + integer :: i, r do i = 1, sys_size - ! Checking whether data file associated with variable position of the currently manipulated conservative variable exists write (file_num, '(I0)') i file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) - ! If it exists, the data file is read if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) q_cons_vf_in(i)%sf @@ -339,17 +287,13 @@ contains end if end do - ! Read bubble variables pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = 1, nb do r = 1, nnode - ! Checking whether data file associated with variable position of the currently manipulated bubble variable - ! exists write (file_num, '(I0)') sys_size + r + (i - 1)*nnode file_loc = trim(t_step_dir) // '/pb' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) - ! If it exists, the data file is read if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) pb%sf(:,:,:, r, i) @@ -362,13 +306,10 @@ contains do i = 1, nb do r = 1, nnode - ! Checking whether data file associated with variable position of the currently manipulated bubble variable - ! exists write (file_num, '(I0)') sys_size + r + (i - 1)*nnode file_loc = trim(t_step_dir) // '/mv' // trim(file_num) // '.dat' inquire (FILE=trim(file_loc), EXIST=file_check) - ! If it exists, the data file is read if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') read (1) mv%sf(:,:,:, r, i) @@ -403,7 +344,6 @@ contains allocate (y_cb_glb(-1:n_glb)) allocate (z_cb_glb(-1:p_glb)) - ! Read in cell boundary locations in x-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'x_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -416,19 +356,14 @@ contains call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting. ') end if - ! Assigning local cell boundary locations x_cb(-1:m) = x_cb_glb((start_idx(1) - 1):(start_idx(1) + m)) - ! Computing cell center locations x_cc(0:m) = (x_cb(0:m) + x_cb(-1:(m - 1)))/2._wp - ! Computing minimum cell width dx = minval(x_cb(0:m) - x_cb(-1:(m - 1))) if (num_procs > 1) call s_mpi_reduce_min(dx) - ! Setting locations of domain bounds x_domain%beg = x_cb(-1) x_domain%end = x_cb(m) if (n > 0) then - ! Read in cell boundary locations in y-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'y_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -441,19 +376,14 @@ contains call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting. ') end if - ! Assigning local cell boundary locations y_cb(-1:n) = y_cb_glb((start_idx(2) - 1):(start_idx(2) + n)) - ! Computing cell center locations y_cc(0:n) = (y_cb(0:n) + y_cb(-1:(n - 1)))/2._wp - ! Computing minimum cell width dy = minval(y_cb(0:n) - y_cb(-1:(n - 1))) if (num_procs > 1) call s_mpi_reduce_min(dy) - ! Setting locations of domain bounds y_domain%beg = y_cb(-1) y_domain%end = y_cb(n) if (p > 0) then - ! Read in cell boundary locations in z-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'z_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -466,14 +396,10 @@ contains call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting. ') end if - ! Assigning local cell boundary locations z_cb(-1:p) = z_cb_glb((start_idx(3) - 1):(start_idx(3) + p)) - ! Computing cell center locations z_cc(0:p) = (z_cb(0:p) + z_cb(-1:(p - 1)))/2._wp - ! Computing minimum cell width dz = minval(z_cb(0:p) - z_cb(-1:(p - 1))) if (num_procs > 1) call s_mpi_reduce_min(dz) - ! Setting locations of domain bounds z_domain%beg = z_cb(-1) z_domain%end = z_cb(p) end if @@ -503,8 +429,6 @@ contains logical :: file_exist integer :: i - ! Open the file to read - if (cfl_adap_dt) then write (file_loc, '(I0,A)') n_start, '.dat' else @@ -518,7 +442,6 @@ contains call s_initialize_mpi_data(q_cons_vf_in) - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) ! Resize some integers so MPI can read even the biggest files @@ -530,7 +453,6 @@ contains str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - ! Read the data for each variable do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) @@ -568,7 +490,6 @@ contains !> @brief Initializes all pre-process modules, allocates data structures, and sets I/O procedure pointers. impure subroutine s_initialize_modules - ! Computation of parameters, allocation procedures, and/or any other tasks needed to properly setup the modules call s_initialize_global_parameters_module() if (bubbles_euler .or. bubbles_lagrange) then call s_initialize_bubbles_model() @@ -586,7 +507,6 @@ contains ! Create the D directory if it doesn't exit, to store the serial data files call s_create_directory('D') - ! Associate pointers for serial or parallel I/O if (parallel_io .neqv. .true.) then s_generate_grid => s_generate_serial_grid s_read_grid_data_files => s_read_serial_grid_data_files @@ -627,10 +547,6 @@ contains integer :: j, k, l real(wp) :: r2 - ! Setup grid (validated if read, generated if not) and IC, then write output - - ! Setting up grid and initial condition - call cpu_time(start) if (old_ic) call s_read_ic_data_files(q_cons_vf) @@ -706,12 +622,8 @@ contains !> @brief Initializes MPI, reads and validates user inputs on rank 0, and decomposes the computational domain. impure subroutine s_initialize_mpi_domain - ! Initialization of the MPI environment - call s_mpi_initialize() - ! Rank 0: assign defaults, read input file, validate consistency - if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() @@ -731,13 +643,11 @@ contains !> @brief Finalizes all pre-process modules, deallocates resources, and shuts down MPI. impure subroutine s_finalize_modules - ! Disassociate pointers for serial and parallel I/O s_generate_grid => null() s_read_grid_data_files => null() s_read_ic_data_files => null() s_write_data_files => null() - ! Deallocation procedures for the modules call s_finalize_mpi_common_module() call s_finalize_grid_module() call s_finalize_variables_conversion_module() @@ -748,7 +658,6 @@ contains call s_finalize_boundary_common_module() if (relax) call s_finalize_relaxation_solver_module() call s_finalize_initial_condition_module() - ! Finalization of the MPI environment call s_mpi_finalize() end subroutine s_finalize_modules diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index 3fb81d3dcb..fb9ffdaaf0 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -27,16 +27,12 @@ contains !> This subroutine initializes the module global array of mixture densities in each grid cell impure subroutine s_initialize_body_forces_module - ! Simulation is at least 2D if (n > 0) then - ! Simulation is 3D if (p > 0) then @:ALLOCATE(rhoM(-buff_size:buff_size + m, -buff_size:buff_size + n, -buff_size:buff_size + p)) - ! Simulation is 2D else @:ALLOCATE(rhoM(-buff_size:buff_size + m, -buff_size:buff_size + n, 0:0)) end if - ! Simulation is 1D else @:ALLOCATE(rhoM(-buff_size:buff_size + m, 0:0, 0:0)) end if diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index a9411261af..40484fd2bf 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -88,7 +88,6 @@ contains character(LEN=name_len), parameter :: file_name = 'run_time.inf' !< Name of the run-time information file character(LEN=path_len + name_len) :: file_path !< Relative path to a file in the case directory character(LEN=8) :: file_date !< Creation date of the run-time information file - ! Opening the run-time information file file_path = trim(case_dir) // '/' // trim(file_name) @@ -107,7 +106,6 @@ contains write (3, '(A)') ''; write (3, '(A)') '' - ! Generating table header for the stability criteria to be outputted write (3, '(13X,A9,13X,A10,13X,A10,13X,A10)', advance="no") trim('Time-step'), trim('dt'), trim('Time'), trim('ICFL Max') if (viscous) then @@ -125,10 +123,8 @@ contains integer :: i !< Generic loop iterator do i = 1, num_fluids - ! Generating the relative path to the CoM data file write (file_path, '(A,I0,A)') '/fluid', i, '_com.dat' file_path = trim(case_dir) // trim(file_path) - ! Creating the formatted data file and setting up its structure open (i + 120, file=trim(file_path), form='formatted', position='append', status='unknown') if (n == 0) then write (i + 120, '(A)') ' Non-Dimensional Time ' // ' Total Mass ' // ' x-loc ' // ' Total Volume ' @@ -153,11 +149,9 @@ contains logical :: file_exist do i = 1, num_probes - ! Generating the relative path to the data file write (file_path, '(A,I0,A)') '/D/probe', i, '_prim.dat' file_path = trim(case_dir) // trim(file_path) - ! Creating the formatted data file and setting up its structure inquire (file=trim(file_path), exist=file_exist) if (file_exist) then @@ -238,10 +232,6 @@ contains end do $:END_GPU_PARALLEL_LOOP() - ! end: Computing Stability Criteria at Current Time-step - - ! Determining local stability criteria extrema at current time-step - #ifdef _CRAYFTN $:GPU_UPDATE(host='[icfl_sf]') @@ -267,7 +257,6 @@ contains end if #endif - ! Determining global stability criteria extrema at current time-step if (num_procs > 1) then call s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & & Rc_min_glb) @@ -277,7 +266,6 @@ contains if (viscous) Rc_min_glb = Rc_min_loc end if - ! Determining the stability criteria extrema over all the time-steps if (icfl_max_glb > icfl_max) icfl_max = icfl_max_glb if (viscous) then @@ -285,7 +273,6 @@ contains if (Rc_min_glb < Rc_min) Rc_min = Rc_min_glb end if - ! Outputting global stability criteria extrema at current time-step if (proc_rank == 0) then write (3, '(13X,I9,13X,F10.6,13X,F10.6,13X,F10.6)', advance="no") t_step, dt, mytime, icfl_max_glb @@ -337,11 +324,8 @@ contains character(LEN=15) :: FMT integer :: i, j, k, l, r real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params - ! Creating or overwriting the time-step root directory write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all' - - ! Creating or overwriting the current time-step directory write (t_step_dir, '(a,i0,a,i0)') trim(case_dir) // '/p_all/p', proc_rank, '/', t_step file_path = trim(t_step_dir) // '/.' @@ -349,13 +333,11 @@ contains if (file_exist) call s_delete_directory(trim(t_step_dir)) call s_create_directory(trim(t_step_dir)) - ! Writing the grid data file in the x-direction file_path = trim(t_step_dir) // '/x_cb.dat' open (2, FILE=trim(file_path), form='unformatted', STATUS='new') write (2) x_cb(-1:m); close (2) - ! Writing the grid data files in the y- and z-directions if (n > 0) then file_path = trim(t_step_dir) // '/y_cb.dat' @@ -370,7 +352,6 @@ contains end if end if - ! Writing the conservative variables data files do i = 1, sys_size write (file_path, '(A,I0,A)') trim(t_step_dir) // '/q_cons_vf', i, '.dat' @@ -432,7 +413,6 @@ contains FMT = "(2F40.14)" end if - ! writing an output directory write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/D' file_path = trim(t_step_dir) // '/.' @@ -451,7 +431,6 @@ contains end if end if - ! 1D if (n == 0 .and. p == 0) then if (model_eqns == 2 .and. (.not. igr)) then do i = 1, sys_size @@ -514,7 +493,6 @@ contains FMT = "(3F40.14)" end if - ! 2D if ((n > 0) .and. (p == 0)) then do i = 1, sys_size write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' @@ -599,7 +577,6 @@ contains FMT = "(4F40.14)" end if - ! 3D if (p > 0) then do i = 1, sys_size write (file_path, '(A,I0,A,I2.2,A,I6.6,A)') trim(t_step_dir) // '/cons.', i, '.', proc_rank, '.', t_step, '.dat' @@ -736,7 +713,6 @@ contains if (file_per_process) then call s_int_to_str(t_step, t_step_string) - ! Initialize MPI data I/O if (down_sample) then call s_initialize_mpi_data_ds(q_cons_temp_ds) else @@ -758,10 +734,8 @@ contains call s_mpi_barrier() call DelayFileAccess(proc_rank) - ! Initialize MPI data I/O call s_initialize_mpi_data(q_cons_vf) - ! Open the file to write all flow variables write (file_loc, '(I0,A,i7.7,A)') t_step, '_', proc_rank, '.dat' file_loc = trim(case_dir) // '/restart_data/lustre_' // trim(t_step_string) // trim(mpiiofs) // trim(file_loc) inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -771,20 +745,17 @@ contains call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) if (down_sample) then - ! Size of local arrays data_size = (m_ds + 3)*(n_ds + 3)*(p_ds + 3) m_glb_save = m_glb_ds + 1 n_glb_save = n_glb_ds + 1 p_glb_save = p_glb_ds + 1 else - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) m_glb_save = m_glb + 1 n_glb_save = n_glb + 1 p_glb_save = p_glb + 1 end if - ! Resize some integers so MPI can write even the biggest files m_MOK = int(m_glb_save + 1, MPI_OFFSET_KIND) n_MOK = int(n_glb_save + 1, MPI_OFFSET_KIND) p_MOK = int(p_glb_save + 1, MPI_OFFSET_KIND) @@ -794,13 +765,11 @@ contains NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) if (bubbles_euler) then - ! Write the data for each variable do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - ! Write pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) @@ -826,8 +795,6 @@ contains call MPI_FILE_CLOSE(ifile, ierr) else - ! Initialize MPI data I/O - if (ib) then call s_initialize_mpi_data(q_cons_vf, ib_markers) else if (present(beta)) then @@ -844,10 +811,8 @@ contains end if call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), mpi_info_int, ifile, ierr) - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) - ! Resize some integers so MPI can write even the biggest files m_MOK = int(m_glb + 1, MPI_OFFSET_KIND) n_MOK = int(n_glb + 1, MPI_OFFSET_KIND) p_MOK = int(p_glb + 1, MPI_OFFSET_KIND) @@ -857,22 +822,18 @@ contains NVARS_MOK = int(alt_sys, MPI_OFFSET_KIND) if (bubbles_euler) then - ! Write the data for each variable do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do - ! Write pb and mv for non-polytropic qbmm if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) @@ -883,7 +844,6 @@ contains do i = 1, sys_size ! TODO: check if correct (sys_size var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) @@ -891,11 +851,9 @@ contains end do end if - ! Correction for the lagrangian subgrid bubble model if (present(beta)) then var_MOK = int(sys_size + 1, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, MPI_IO_DATA%view(sys_size + 1), 'native', mpi_info_int, ierr) @@ -904,7 +862,6 @@ contains call MPI_FILE_CLOSE(ifile, ierr) - ! Write ib data if (ib) then call s_write_parallel_ib_data(t_step) ! write (file_loc, '(A)') 'ib.dat' file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) call @@ -929,8 +886,6 @@ contains character(LEN=path_len + 2*name_len) :: file_path character(LEN=path_len + 2*name_len) :: t_step_dir - ! Creating or overwriting the time-step root directory - write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all' write (t_step_dir, '(a,i0,a,i0)') trim(case_dir) // '/p_all/p', proc_rank, '/', time_step write (file_path, '(A,I0,A)') trim(t_step_dir) // '/ib_data.dat' @@ -957,7 +912,6 @@ contains $:GPU_UPDATE(host='[ib_markers%sf]') - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) m_MOK = int(m_glb + 1, MPI_OFFSET_KIND) n_MOK = int(n_glb + 1, MPI_OFFSET_KIND) @@ -1014,7 +968,6 @@ contains real(wp), dimension(num_fluids, 5), intent(in) :: c_mass_in integer :: i !< Generic loop iterator real(wp) :: nondim_time !< Non-dimensional time - ! Non-dimensional time calculation if (t_step_old /= dflt_int) then nondim_time = real(t_step + t_step_old, wp)*dt @@ -1023,16 +976,16 @@ contains end if if (proc_rank == 0) then - if (n == 0) then ! 1D simulation - do i = 1, num_fluids ! Loop through fluids + if (n == 0) then + do i = 1, num_fluids write (i + 120, '(6X,4F24.12)') nondim_time, c_mass_in(i, 1), c_mass_in(i, 2), c_mass_in(i, 5) end do - else if (p == 0) then ! 2D simulation - do i = 1, num_fluids ! Loop through fluids + else if (p == 0) then + do i = 1, num_fluids write (i + 120, '(6X,5F24.12)') nondim_time, c_mass_in(i, 1), c_mass_in(i, 2), c_mass_in(i, 3), c_mass_in(i, 5) end do - else ! 3D simulation - do i = 1, num_fluids ! Loop through fluids + else + do i = 1, num_fluids write (i + 120, '(6X,6F24.12)') nondim_time, c_mass_in(i, 1), c_mass_in(i, 2), c_mass_in(i, 3), c_mass_in(i, & & 4), c_mass_in(i, 5) end do @@ -1091,7 +1044,6 @@ contains T = dflt_T_guess - ! Non-dimensional time calculation if (time_stepper == 23) then nondim_time = mytime else @@ -1103,7 +1055,6 @@ contains end if do i = 1, num_probes - ! Zeroing out flow variables for all processors rho = 0._wp do s = 1, num_vels vel(s) = 0._wp @@ -1130,8 +1081,7 @@ contains end do damage_state = 0._wp - ! Find probe location in terms of indices on a specific processor - if (n == 0) then ! 1D simulation + if (n == 0) then if ((probe(i)%x >= x_cb(-1)) .and. (probe(i)%x <= x_cb(m))) then do s = -1, m distx(s) = x_cb(s) - probe(i)%x @@ -1234,7 +1184,7 @@ contains accel = accel_mag(j - 2, k, l) end if - else if (p == 0) then ! 2D simulation + else if (p == 0) then if (chemistry) then do d = 1, num_species rhoYks(d) = q_cons_vf(chemxb + d - 1)%sf(j - 2, k - 2, l) @@ -1315,7 +1265,7 @@ contains & 0._wp, 0._wp, c, qv) end if end if - else ! 3D + else if ((probe(i)%x >= x_cb(-1)) .and. (probe(i)%x <= x_cb(m))) then if ((probe(i)%y >= y_cb(-1)) .and. (probe(i)%y <= y_cb(n))) then if ((probe(i)%z >= z_cb(-1)) .and. (probe(i)%z <= z_cb(p))) then @@ -1464,7 +1414,7 @@ contains end do if (integral_wrt .and. bubbles_euler) then - if (n == 0) then ! 1D simulation + if (n == 0) then do i = 1, num_integrals int_pres = 0._wp max_pres = 0._wp @@ -1590,7 +1540,6 @@ contains impure subroutine s_close_run_time_information_file real(wp) :: run_time !< Run-time of the simulation - ! Writing the footer of and closing the run-time information file write (3, '(A)') ' ' write (3, '(A)') '' @@ -1642,8 +1591,6 @@ contains integer :: i, m_ds, n_ds, p_ds - ! Allocating/initializing ICFL, VCFL, CCFL and Rc stability criteria - if (run_time_info) then @:ALLOCATE(icfl_sf(0:m, 0:n, 0:p)) icfl_max = 0._wp @@ -1684,7 +1631,6 @@ contains end if if (run_time_info) then - ! Deallocating the ICFL, VCFL, CCFL, and Rc stability criteria @:DEALLOCATE(icfl_sf) if (viscous) then @:DEALLOCATE(vcfl_sf, Rc_sf) diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index f97f696636..26d047b235 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -241,7 +241,7 @@ contains q_prim_vf(E_idx)%sf(j, k, l) = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, num_fluids - ! Se the pressure inside a moving immersed boundary based upon the pressure of the image point. + ! Set the pressure inside a moving immersed boundary based upon the pressure of the image point. ! acceleration, and normal vector direction q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, & & l) + pres_IP/(1._wp - 2._wp*abs(gp%levelset*alpha_rho_IP(q)/pres_IP) & diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index bfdc1686b7..0e9fbe7119 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -204,7 +204,6 @@ contains $:GPU_ENTER_DATA(attach='[q_prim_qp%vf(psi_idx)%sf]') end if - ! Allocation/Association of flux_n, flux_src_n, and flux_gsrc_n if (.not. igr) then @:ALLOCATE(flux_n(1:num_dims)) @:ALLOCATE(flux_src_n(1:num_dims)) @@ -276,11 +275,9 @@ contains end do end if end do - ! END: Allocation/Association of flux_n, flux_src_n, and flux_gsrc_n end if if ((.not. igr) .or. dummy) then - ! Allocation of dq_prim_ds_qp @:ALLOCATE(dq_prim_dx_qp(1:1)) @:ALLOCATE(dq_prim_dy_qp(1:1)) @:ALLOCATE(dq_prim_dz_qp(1:1)) @@ -288,7 +285,6 @@ contains @:ALLOCATE(qL_prim(1:num_dims)) @:ALLOCATE(qR_prim(1:num_dims)) - ! Allocation/Association of dqK_prim_ds_n @:ALLOCATE(dqL_prim_dx_n(1:num_dims)) @:ALLOCATE(dqL_prim_dy_n(1:num_dims)) @:ALLOCATE(dqL_prim_dz_n(1:num_dims)) @@ -524,9 +520,6 @@ contains if (mpp_lim .and. bubbles_euler) then @:ALLOCATE(alf_sum%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end if - ! END: Allocation/Association of qK_cons_n and qK_prim_n - - ! Allocation of gm_alphaK_n if (.not. igr) then @:ALLOCATE(gm_alphaL_n(1:num_dims)) @:ALLOCATE(gm_alphaR_n(1:num_dims)) diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 7d12f80faf..e061139419 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -76,7 +76,6 @@ contains !! is so, the input file is then read in. impure subroutine s_read_input_file - ! Relative path to the input file provided by the user character(LEN=name_len), parameter :: file_path = './simulation.inp' logical :: file_exist !< Logical used to check the existence of the input file integer :: iostatus @@ -84,8 +83,6 @@ contains character(len=1000) :: line - ! Namelist of the global parameters which may be specified by user - namelist /user_inputs/ case_dir, run_time_info, m, n, p, dt, & t_step_start, t_step_stop, t_step_save, t_step_print, & model_eqns, mpp_lim, time_stepper, weno_eps, & @@ -117,8 +114,6 @@ contains & hyper_cleaning, hyper_cleaning_speed, hyper_cleaning_tau, alf_factor, num_igr_iters, num_igr_warm_start_iters, & & int_comp, ic_eps, ic_beta, nv_uvm_out_of_core, nv_uvm_igr_temps_on_gpu, nv_uvm_pref_gpu, down_sample, fft_wrt - ! Checking that an input file has been provided by the user. If it has, then the input file is read in, otherwise, - ! simulation exits. inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then @@ -138,7 +133,6 @@ contains bodyForces = .true. end if - ! Store m,n,p into global m,n,p m_glb = m n_glb = n p_glb = p @@ -160,13 +154,8 @@ contains !! a meaningful configuration for the simulation. impure subroutine s_check_input_file - ! Relative path to the current directory file in the case directory character(LEN=path_len) :: file_path - - ! Logical used to check the existence of the current directory file - logical :: file_exist - - ! Logistics + logical :: file_exist file_path = trim(case_dir) // '/.' @@ -189,11 +178,7 @@ contains character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the starting time-step directory character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files logical :: file_exist - ! Logical used to check the existence of the data files - - integer :: i, r !< Generic loop iterator - ! Confirming that the directory from which the initial condition and the grid data files are to be read in exists and - ! exiting otherwise + integer :: i, r if (cfl_dt) then write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all/p', proc_rank, '/', n_start @@ -214,7 +199,6 @@ contains call s_assign_default_bc_type(bc_type) end if - ! Cell-boundary Locations in x-direction file_path = trim(t_step_dir) // '/x_cb.dat' inquire (FILE=trim(file_path), EXIST=file_exist) @@ -238,7 +222,6 @@ contains end do end if - ! Cell-boundary Locations in y-direction if (n > 0) then file_path = trim(t_step_dir) // '/y_cb.dat' @@ -255,7 +238,6 @@ contains y_cc(0:n) = y_cb(-1:n - 1) + dy(0:n)/2._wp end if - ! Cell-boundary Locations in z-direction if (p > 0) then file_path = trim(t_step_dir) // '/z_cb.dat' @@ -344,7 +326,6 @@ contains allocate (y_cb_glb(-1:n_glb)) allocate (z_cb_glb(-1:p_glb)) - ! Read in cell boundary locations in x-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'x_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -367,11 +348,8 @@ contains call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if - ! Assigning local cell boundary locations x_cb(-1:m) = x_cb_glb((start_idx(1) - 1):(start_idx(1) + m)) - ! Computing the cell width distribution dx(0:m) = x_cb(0:m) - x_cb(-1:m - 1) - ! Computing the cell center locations x_cc(0:m) = x_cb(-1:m - 1) + dx(0:m)/2._wp if (ib) then @@ -385,7 +363,6 @@ contains end if if (n > 0) then - ! Read in cell boundary locations in y-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'y_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -398,15 +375,11 @@ contains call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if - ! Assigning local cell boundary locations y_cb(-1:n) = y_cb_glb((start_idx(2) - 1):(start_idx(2) + n)) - ! Computing the cell width distribution dy(0:n) = y_cb(0:n) - y_cb(-1:n - 1) - ! Computing the cell center locations y_cc(0:n) = y_cb(-1:n - 1) + dy(0:n)/2._wp if (p > 0) then - ! Read in cell boundary locations in z-direction file_loc = trim(case_dir) // '/restart_data' // trim(mpiiofs) // 'z_cb.dat' inquire (FILE=trim(file_loc), EXIST=file_exist) @@ -419,11 +392,8 @@ contains call s_mpi_abort('File ' // trim(file_loc) // 'is missing. Exiting.') end if - ! Assigning local cell boundary locations z_cb(-1:p) = z_cb_glb((start_idx(3) - 1):(start_idx(3) + p)) - ! Computing the cell width distribution dz(0:p) = z_cb(0:p) - z_cb(-1:p - 1) - ! Computing the cell center locations z_cc(0:p) = z_cb(-1:p - 1) + dz(0:p)/2._wp end if end if @@ -442,7 +412,6 @@ contains if (file_exist) then call MPI_FILE_OPEN(MPI_COMM_SELF, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - ! Initialize MPI data I/O if (down_sample) then call s_initialize_mpi_data_ds(q_cons_vf) else @@ -454,20 +423,17 @@ contains end if if (down_sample) then - ! Size of local arrays data_size = (m_ds + 3)*(n_ds + 3)*(p_ds + 3) m_glb_read = m_glb_ds + 1 n_glb_read = n_glb_ds + 1 p_glb_read = p_glb_ds + 1 else - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) m_glb_read = m_glb + 1 n_glb_read = n_glb + 1 p_glb_read = p_glb + 1 end if - ! Resize some integers so MPI can read even the biggest file m_MOK = int(m_glb_read + 1, MPI_OFFSET_KIND) n_MOK = int(m_glb_read + 1, MPI_OFFSET_KIND) p_MOK = int(m_glb_read + 1, MPI_OFFSET_KIND) @@ -476,7 +442,6 @@ contains str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - ! Read the data for each variable if (bubbles_euler .or. elasticity) then do i = 1, sys_size ! adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) @@ -514,7 +479,6 @@ contains call s_mpi_abort('File ' // trim(file_loc) // ' is missing. Exiting.') end if else - ! Open the file to read conservative variables if (cfl_dt) then write (file_loc, '(I0,A)') n_start, '.dat' else @@ -526,18 +490,14 @@ contains if (file_exist) then call MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, MPI_MODE_RDONLY, mpi_info_int, ifile, ierr) - ! Initialize MPI data I/O - if (ib) then call s_initialize_mpi_data(q_cons_vf, ib_markers) else call s_initialize_mpi_data(q_cons_vf) end if - ! Size of local arrays data_size = (m + 1)*(n + 1)*(p + 1) - ! Resize some integers so MPI can read even the biggest file m_MOK = int(m_glb + 1, MPI_OFFSET_KIND) n_MOK = int(n_glb + 1, MPI_OFFSET_KIND) p_MOK = int(p_glb + 1, MPI_OFFSET_KIND) @@ -546,11 +506,9 @@ contains str_MOK = int(name_len, MPI_OFFSET_KIND) NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) - ! Read the data for each variable if (bubbles_euler .or. elasticity) then do i = 1, sys_size ! adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) @@ -560,7 +518,6 @@ contains if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) @@ -571,7 +528,6 @@ contains do i = 1, sys_size var_MOK = int(i, MPI_OFFSET_KIND) - ! Initial displacement to skip at beginning of file disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) call MPI_FILE_SET_VIEW(ifile, disp, mpi_io_p, MPI_IO_DATA%view(i), 'native', mpi_info_int, ierr) @@ -936,7 +892,6 @@ contains end do end if - ! Reading in the user provided initial condition and grid data if (down_sample) then call s_read_data_files(q_cons_temp) call s_upsample_data(q_cons_ts(1)%vf, q_cons_temp) @@ -951,7 +906,6 @@ contains call s_read_data_files(q_cons_ts(1)%vf) end if - ! Populating the buffers of the grid variables using the boundary conditions call s_populate_grid_variables_buffers() if (model_eqns == 3) call s_initialize_internal_energy_equations(q_cons_ts(1)%vf) @@ -1005,11 +959,8 @@ contains #endif #endif - ! Initializing MPI execution environment - call s_mpi_initialize() - ! Bind GPUs if OpenACC is enabled #ifdef MFC_GPU #ifndef MFC_MPI local_size = 1 @@ -1032,7 +983,6 @@ contains #endif #endif - ! Rank 0: assign defaults, read input file, validate (abort on inconsistencies) if (proc_rank == 0) then call s_assign_default_values_to_user_inputs() call s_read_input_file() @@ -1054,8 +1004,6 @@ contains #endif end if - ! Broadcast user inputs and decompose domain (skipped in serial) - call s_mpi_bcast_user_inputs() call s_initialize_parallel_io() @@ -1068,7 +1016,6 @@ contains subroutine s_initialize_gpu_vars integer :: i - ! Update GPU DATA if (.not. down_sample) then do i = 1, sys_size @@ -1170,7 +1117,6 @@ contains if (surface_tension) call s_finalize_surface_tension_module() if (bodyForces) call s_finalize_body_forces_module() - ! Terminating MPI execution environment call s_mpi_finalize() end subroutine s_finalize_modules From 55e39d8d1ce2b1056787008713f7d53e4cec5886 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 20:21:31 -0400 Subject: [PATCH 12/25] Fix stale comments and remove dead code --- src/common/m_helper_basic.fpp | 6 ------ src/post_process/m_derived_variables.fpp | 7 +------ src/post_process/m_start_up.fpp | 2 -- src/pre_process/m_assign_variables.fpp | 4 ---- src/pre_process/m_boundary_conditions.fpp | 12 ++++++------ src/pre_process/m_check_patches.fpp | 3 --- src/pre_process/m_perturbation.fpp | 4 ++-- src/simulation/m_bubbles.fpp | 9 --------- src/simulation/m_hyperelastic.fpp | 1 - src/simulation/m_surface_tension.fpp | 2 +- 10 files changed, 10 insertions(+), 40 deletions(-) diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 6f957604f6..47ec5073e7 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -94,12 +94,6 @@ contains res = all(f_is_default(var_array)) - ! logical :: res_array(size(var_array)) integer :: i - - ! do i = 1, size(var_array) res_array(i) = f_is_default(var_array(i)) end do - - ! res = all(res_array) - end function f_all_default !> Checks if a real(wp) variable is an integer. diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 54f66e856d..11ef1d543e 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -197,8 +197,6 @@ contains if (f_approx_equal(top, bottom)) then slope = 1._wp - ! ELSEIF((top == 0._wp .AND. bottom /= 0._wp) & .OR. & (bottom == 0._wp .AND. top /= 0._wp)) THEN slope = - ! 0._wp else slope = (top*bottom)/(bottom**2._wp + 1.e-16_wp) end if @@ -235,10 +233,7 @@ contains real(wp), dimension(ndim, ndim), intent(inout) :: A real(wp), dimension(ndim), intent(inout) :: b real(wp), dimension(ndim), intent(out) :: sol - - ! EXTERNAL DGESV - - integer :: i, j, k + integer :: i, j, k ! Forward elimination with partial pivoting diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index e7cb2d8461..84ee37c02d 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -1010,8 +1010,6 @@ contains s_read_data_files => null() - ! if (sim_data .and. proc_rank == 0) then call s_close_intf_data_file() call s_close_energy_data_file() end if - if (fft_wrt) then if (c_associated(fwd_plan_x)) call fftw_destroy_plan(fwd_plan_x) if (c_associated(fwd_plan_y)) call fftw_destroy_plan(fwd_plan_y) diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index 57016fd0fa..ef44ae534a 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -572,10 +572,6 @@ contains if (1._wp - eta < 1.e-16_wp) patch_id_fp(j, k, l) = patch_id - ! if (j == 1) then print *, (q_prim_vf(bub_idx%rs(i))%sf(j, k, l), i = 1, nb) print *, (q_prim_vf(bub_idx%fullmom(i, 1, - ! 0))%sf(j, k, l), i = 1, nb) print *, (R0(i), i = 1, nb) print *, patch_icpp(patch_id)%r0 print *, (bub_idx%rs(i), i = 1, - ! nb) print *, (bub_idx%fullmom(i, 1, 0), i = 1, nb) end if - end subroutine s_assign_patch_species_primitive_variables !> @brief Nullifies the patch primitive variable assignment procedure pointer. diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index 051dd7d18d..f7e52695aa 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -30,7 +30,7 @@ contains integer, intent(in) :: patch_id integer :: j - ! Patch is a vertical line at x_beg or x_end + ! Patch is a line segment along y on the x-boundary face if (patch_bc(patch_id)%dir == 1) then y_centroid = patch_bc(patch_id)%centroid(2) @@ -39,7 +39,7 @@ contains y_boundary%beg = y_centroid - 0.5_wp*length_y y_boundary%end = y_centroid + 0.5_wp*length_y - ! Patch is a vertical line at x_beg and x_beg is a domain boundary + ! Apply patch if x boundary is a domain boundary #:for BOUND, X, LOC, IDX in [('beg', '-i', -1, 1), ('end', 'm+i', 1, 2)] if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_x%${BOUND}$ < 0) then do j = 0, n @@ -51,7 +51,7 @@ contains #:endfor end if - ! Patch is a vertical line at y_beg or y_end + ! Patch is a line segment along x on the y-boundary face if (patch_bc(patch_id)%dir == 2) then x_centroid = patch_bc(patch_id)%centroid(1) length_x = patch_bc(patch_id)%length(1) @@ -59,7 +59,7 @@ contains x_boundary%beg = x_centroid - 0.5_wp*length_x x_boundary%end = x_centroid + 0.5_wp*length_x - ! Patch is a vertical line at x_beg and x_beg is a domain boundary + ! Apply patch if y boundary is a domain boundary #:for BOUND, Y, LOC, IDX in [('beg', '-i', -1, 1), ('end', 'n+i', 1, 2)] if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_y%${BOUND}$ < 0) then do j = 0, m @@ -151,7 +151,7 @@ contains z_boundary%beg = z_centroid - 0.5_wp*length_z z_boundary%end = z_centroid + 0.5_wp*length_z - ! Patch is a circle at x_beg and x_beg is a domain boundary + ! Patch is a rectangle on the x-boundary face #:for BOUND, X, LOC, IDX in [('beg', '-i', -1, 1), ('end', 'm+i', 1, 2)] if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_x%${BOUND}$ < 0) then do k = 0, p @@ -176,7 +176,7 @@ contains z_boundary%beg = z_centroid - 0.5_wp*length_z z_boundary%end = z_centroid + 0.5_wp*length_z - ! Patch is a circle at y_beg and y_beg is a domain boundary + ! Patch is a rectangle on the y-boundary face #:for BOUND, Y, LOC, IDX in [('beg', '-i', -1, 1), ('end', 'n+i', 1, 2)] if (patch_bc(patch_id)%loc == ${LOC}$ .and. bc_y%${BOUND}$ < 0) then do k = 0, p diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 69c917616e..4287e31d17 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -41,7 +41,6 @@ contains do i = 1, num_patches_max if (i <= num_patches) then - ! call s_check_patch_geometry(i) call s_int_to_str(i, iStr) @:PROHIBIT(patch_icpp(i)%geometry == 6, & & "Invalid patch geometry number. " // "patch_icpp(" // trim(iStr) // ")%geometry is deprecated.") @@ -517,8 +516,6 @@ contains end if if (chemistry) then - !@:ASSERT(all(patch_icpp(patch_id)%Y(1:num_species) >= 0._wp), "Patch " // trim(iStr) // ".") - !@:ASSERT(any(patch_icpp(patch_id)%Y(1:num_species) > verysmall), "Patch " // trim(iStr) // ".") end if end subroutine s_check_active_patch_primitive_variables diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index 698fe79a37..24ee888966 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -45,8 +45,8 @@ contains perturb_alpha = q_prim_vf(E_idx + perturb_sph_fluid)%sf(i, j, k) - ! Perturb partial density fields to match perturbed volume fraction fields IF ((perturb_alpha >= 25e-2_wp) .AND. - ! (perturb_alpha <= 75e-2_wp)) THEN + ! Perturb partial density fields to match perturbed volume fraction fields when the volume fraction is not near + ! 0 or 1 if ((.not. f_approx_equal(perturb_alpha, 0._wp)) .and. (.not. f_approx_equal(perturb_alpha, 1._wp))) then do l = 1, num_fluids q_prim_vf(l)%sf(i, j, k) = q_prim_vf(E_idx + l)%sf(i, j, k)*fluid_rho(l) diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index b38dbec1b8..03b1a9604b 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -190,12 +190,6 @@ contains f_Hdot = (fCpbw/(1._wp + fBtait) + 1._wp)**(-1._wp/fntait)*(tmp1 + tmp2) - (fCpinf/(1._wp + fBtait) + 1._wp) & & **(-1._wp/fntait)*fCpinf_dot - ! Hdot = (Cpbw/(1+B) + 1)^(-1/n_tait)*(-3 gam)*(R0/R)^(3gam) V/R f_Hdot = - ! ((fCpbw/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*(-3._wp)*gam * & ( (fR0/fR)**(3._wp*gam ))*(fV/fR) - - ! Hdot = Hdot - (Cpinf/(1+B) + 1)^(-1/n_tait) Cpinfdot f_Hdot = f_Hdot - - ! ((fCpinf/(1._wp+fBtait)+1._wp)**(-1._wp/fntait))*fCpinf_dot - end function f_Hdot !> Function that computes the bubble radial acceleration for Rayleigh-Plesset bubbles @@ -210,9 +204,6 @@ contains real(wp), intent(in) :: fCp, fRho, fR, fV, fCpbw real(wp) :: f_rddot_RP - !! rddot = (1/r) ( -3/2 rdot^2 + ((r0/r)^3\gamma - Cp)/rho ) rddot = (1/r) ( -3/2 rdot^2 + (tmp1 - Cp)/rho ) rddot = (1/r) ( - !! tmp2 ) - f_rddot_RP = (-1.5_wp*(fV**2._wp) + (fCpbw - fCp)/fRho)/fR end function f_rddot_RP diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index db355a1233..e1a252a6bf 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -111,7 +111,6 @@ contains & Gs_hyper) rho = max(rho, sgm_eps) G_local = max(G_local, sgm_eps) - ! if ( G_local <= verysmall ) G_K = 0._wp if (G_local > verysmall) then $:GPU_LOOP(parallelism='[seq]') diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index fc07b6b02b..ab7081533a 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -272,7 +272,7 @@ contains do i = 1, num_dims c_divs(num_dims + 1)%sf(j, k, l) = c_divs(num_dims + 1)%sf(j, k, l) + c_divs(i)%sf(j, k, l)**2._wp end do - ! c_divs(num_dims + 1)%sf(j, k, l) = & sqrt(c_divs(num_dims + 1)%sf(j, k, l)) + c_divs(num_dims + 1)%sf(j, k, l) = sqrt(real(c_divs(num_dims + 1)%sf(j, k, l), kind=wp)) end do end do From b6fa124867a8458dd3b44b5b5b8f0646eb94b249 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sat, 21 Mar 2026 21:47:41 -0400 Subject: [PATCH 13/25] Remove commented-out dead code (debug prints, old IB I/O, stale implementations) --- src/pre_process/m_assign_variables.fpp | 1 - src/pre_process/m_check_ib_patches.fpp | 1 - src/pre_process/m_icpp_patches.fpp | 2 -- src/simulation/m_bubbles_EL.fpp | 3 --- src/simulation/m_data_output.fpp | 14 -------------- src/simulation/m_ib_patches.fpp | 1 - src/simulation/m_ibm.fpp | 2 -- src/simulation/m_rhs.fpp | 6 ------ src/simulation/m_riemann_solvers.fpp | 12 ------------ 9 files changed, 42 deletions(-) diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index ef44ae534a..79f4b3825c 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -558,7 +558,6 @@ contains do i = 1, nb if (f_is_default(real(q_prim_vf(bub_idx%ps(i))%sf(j, k, l), kind=wp))) then q_prim_vf(bub_idx%ps(i))%sf(j, k, l) = pb0(i) - ! print *, 'setting to pb0' end if if (f_is_default(real(q_prim_vf(bub_idx%ms(i))%sf(j, k, l), kind=wp))) then q_prim_vf(bub_idx%ms(i))%sf(j, k, l) = mass_v0(i) diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index b8090ab1c7..cbeadc71a3 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -36,7 +36,6 @@ contains do i = 1, num_patches_max if (i <= num_ibs) then - ! call s_check_patch_geometry(i) call s_int_to_str(i, iStr) @:PROHIBIT(patch_ib(i)%geometry == dflt_int, "IB patch undefined. patch_ib("//trim(iStr)//")%geometry must be set.") diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index ad399ac64a..1985fbd040 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -1386,8 +1386,6 @@ contains write (*, "(A, 3(2X, F20.10))") " > Cen:", (bbox%min(1:3) + bbox%max(1:3))/2._wp write (*, "(A, 3(2X, F20.10))") " > Max:", bbox%max(1:3) - ! call s_model_write("__out__.stl", model) call s_model_write("__out__.obj", model) - grid_mm(1,:) = (/minval(x_cc) - 0.e5_wp*dx, maxval(x_cc) + 0.e5_wp*dx/) grid_mm(2,:) = (/minval(y_cc) - 0.e5_wp*dy, maxval(y_cc) + 0.e5_wp*dy/) diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 925ee63639..dcce585649 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -1374,9 +1374,6 @@ contains inquire (FILE=trim(file_loc), EXIST=file_exist) if (.not. file_exist) then open (12, FILE=trim(file_loc), form='formatted', position='rewind') - ! write (12, *) 'currentTime, averageVoidFraction, ', & 'maximumVoidFraction, totalParticlesVolume' write (12, *) - ! 'The averageVoidFraction value does ', & 'not reflect the real void fraction in the cloud since the ', & 'cells - ! which do not have bubbles are not accounted' else open (12, FILE=trim(file_loc), form='formatted', position='append') end if diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 40484fd2bf..4b4030c898 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -395,11 +395,6 @@ contains ! Writing the IB markers if (ib) then call s_write_serial_ib_data(t_step) - ! write (file_path, '(A,I0,A)') trim(t_step_dir)//'/ib.dat' - - ! open (2, FILE=trim(file_path), & FORM='unformatted', & STATUS='new') - - ! write (2) ib_markers%sf(0:m, 0:n, 0:p); close (2) end if gamma = gammas(1) @@ -864,15 +859,6 @@ contains if (ib) then call s_write_parallel_ib_data(t_step) - ! write (file_loc, '(A)') 'ib.dat' file_loc = trim(case_dir)//'/restart_data'//trim(mpiiofs)//trim(file_loc) call - ! MPI_FILE_OPEN(MPI_COMM_WORLD, file_loc, ior(MPI_MODE_WRONLY, MPI_MODE_CREATE), & mpi_info_int, ifile, ierr) - - ! var_MOK = int(sys_size + 1, MPI_OFFSET_KIND) disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1 + - ! int(t_step/t_step_save)) - - ! call MPI_FILE_SET_VIEW(ifile, disp, MPI_INTEGER, MPI_IO_IB_DATA%view, & 'native', mpi_info_int, ierr) call - ! MPI_FILE_WRITE_ALL(ifile, MPI_IO_IB_DATA%var%sf, data_size, & MPI_INTEGER, status, ierr) call - ! MPI_FILE_CLOSE(ifile, ierr) end if end if #endif diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index 5be5670396..3c5ade657f 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -589,7 +589,6 @@ contains do k = kl, kr do j = jl, jr do i = il, ir - ! do i = -gp_layers, m+gp_layers if (grid_geometry == 3) then call s_convert_cylindrical_to_cartesian_coord(y_cc(j), z_cc(k)) else diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 26d047b235..9e2631937a 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -905,8 +905,6 @@ contains !> @brief Computes pressure and viscous forces and torques on immersed bodies via a volume integration method. subroutine s_compute_ib_forces(q_prim_vf, fluid_pp) - ! real(wp), dimension(idwbuff(1)%beg:idwbuff(1)%end, & idwbuff(2)%beg:idwbuff(2)%end, & idwbuff(3)%beg:idwbuff(3)%end), - ! intent(in) :: pressure type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf type(physical_parameters), dimension(1:num_fluids), intent(in) :: fluid_pp integer :: gp_id, i, j, k, l, q, ib_idx, fluid_idx diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 0e9fbe7119..6c5f5cf719 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -760,9 +760,6 @@ contains irx%beg = 0; iry%beg = 0; irz%beg = -1 end if irx%end = m; iry%end = n; irz%end = p - ! $:GPU_UPDATE(host='[qL_rsx_vf,qR_rsx_vf]') print *, "L", qL_rsx_vf(100:300, 0, 0, 1) print *, "R", - ! qR_rsx_vf(100:300, 0, 0, 1) - ! Computing Riemann Solver Flux and Source Flux call nvtxStartRange("RHS-RIEMANN-SOLVER") call s_riemann_solver(qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, dqR_prim_dx_n(id)%vf, dqR_prim_dy_n(id)%vf, & @@ -771,9 +768,6 @@ contains & q_prim_qp%vf, flux_n(id)%vf, flux_src_n(id)%vf, flux_gsrc_n(id)%vf, id, irx, iry, irz) call nvtxEndRange - !$:GPU_UPDATE(host='[flux_n(1)%vf(1)%sf]') - ! print *, "FLUX", flux_n(1)%vf(1)%sf(100:300, 0, 0) - ! Additional physics and source terms RHS addition for advection source call nvtxStartRange("RHS-ADVECTION-SRC") call s_compute_advection_source_term(id, rhs_vf, q_cons_qp, q_prim_qp, flux_src_n(id)) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 5e941f61f0..464468f83f 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -490,18 +490,6 @@ contains end do end if - ! elastic energy update if ( hyperelasticity ) 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 ! Elastic contribution to energy if G large enough if ((G_L > 1.e-3_wp) - ! .and. (G_R > 1.e-3_wp)) then E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) E_R = E_R + - ! G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size-1 - ! tau_e_L(i) = G_L*qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) tau_e_R(i) = G_R*qR_prim_rs${XYZ}$_vf(j - ! + 1, k, l, strxb - 1 + i) end do $:GPU_LOOP(parallelism='[seq]') do i = 1, b_size-1 tau_e_L(i) = 0._wp - ! tau_e_R(i) = 0._wp end do $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims xi_field_L(i) = - ! qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - - ! 1 + i) end do end if end if - @:compute_average_state() call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, c_L, & From 861cb51866d8b7fbe92f8e53d613f92895545784 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 01:22:07 -0400 Subject: [PATCH 14/25] Add physics documentation: paper references, equation citations, algorithm explanations --- src/common/m_chemistry.fpp | 1 + src/common/m_helper.fpp | 10 +++++----- src/common/m_phase_change.fpp | 16 +++++++++------- src/common/m_variables_conversion.fpp | 17 ++++++++++------- src/post_process/m_derived_variables.fpp | 17 +++++++++++------ src/pre_process/m_icpp_patches.fpp | 1 + src/simulation/m_bubbles.fpp | 9 +++++---- src/simulation/m_cbc.fpp | 2 +- src/simulation/m_hyperelastic.fpp | 8 ++++---- src/simulation/m_hypoelastic.fpp | 1 + src/simulation/m_ibm.fpp | 6 ++++-- src/simulation/m_pressure_relaxation.fpp | 4 +++- src/simulation/m_riemann_solvers.fpp | 12 +++++++++++- src/simulation/m_surface_tension.fpp | 3 +++ src/simulation/m_weno.fpp | 13 ++++++++----- 15 files changed, 77 insertions(+), 43 deletions(-) diff --git a/src/common/m_chemistry.fpp b/src/common/m_chemistry.fpp index 7ffb622e13..65734d6987 100644 --- a/src/common/m_chemistry.fpp +++ b/src/common/m_chemistry.fpp @@ -41,6 +41,7 @@ contains call get_mixture_viscosity_mixavg(T_L, Ys_L, Re_L) call get_mixture_viscosity_mixavg(T_R, Ys_R, Re_R) + ! Convert dynamic viscosity to inverse (MFC stores 1/mu for Reynolds number convention) Re_L = 1.0_wp/Re_L Re_R = 1.0_wp/Re_R diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index e8b0118066..bfdeecc74f 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -174,18 +174,18 @@ contains integer :: ir real(wp), dimension(nb) :: chi_vw0, cp_m0, k_m0, rho_m0, x_vw, omegaN, rhol0 real(wp), parameter :: k_poly = 1._wp !< polytropic index used to compute isothermal natural frequency - ! phi_vg & phi_gv (phi_gg = phi_vv = 1) (Eq. 2.22 in Ando 2010) + ! Chapman-Enskog transport coefficients for vapor-gas mixture, Ando JAS (2010) Eq. 2.22 phi_vg = (1._wp + sqrt(mu_v/mu_g)*(M_g/M_v)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_v/M_g)) phi_gv = (1._wp + sqrt(mu_g/mu_v)*(M_v/M_g)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_g/M_v)) - ! internal bubble pressure + ! Initial internal bubble pressure (Euler number + Laplace pressure) pb0 = Eu + 2._wp/Web/R0 - ! mass fraction of vapor (Eq. 2.19 in Ando 2010) + ! Vapor mass fraction at bubble wall, Ando JAS (2010) Eq. 2.19 chi_vw0 = 1._wp/(1._wp + R_v/R_g*(pb0/pv - 1._wp)) - ! specific heat for gas/vapor mixture + ! Mixture specific heat from mass-weighted vapor/gas contributions cp_m0 = chi_vw0*R_v*gam_v/(gam_v - 1._wp) + (1._wp - chi_vw0)*R_g*gam_g/(gam_g - 1._wp) ! mole fraction of vapor (Eq. 2.23 in Ando 2010) @@ -206,7 +206,7 @@ contains ! Peclet numbers Pe_T(:) = rho_m0*cp_m0(:)/k_m0(:) - ! natural frequencies (Eq. B.1) + ! Bubble natural frequency, Ando JAS (2010) Eq. B.1 omegaN(:) = sqrt(3._wp*k_poly*Ca + 2._wp*(3._wp*k_poly - 1._wp)/(Web*R0))/R0/sqrt(rho0ref) do ir = 1, nb call s_transcoeff(omegaN(ir)*R0(ir), Pe_T(ir)*R0(ir), Re_trans_T(ir), Im_trans_T(ir)) diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index 6fdfa2afb1..d04cfc5e5b 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -22,12 +22,12 @@ module m_phase_change !> @name Parameters for the first order transition phase change !> @{ - integer, parameter :: max_iter = 1e8_wp !< max # of iterations - real(wp), parameter :: pCr = 4.94e7_wp !< Critical water pressure - real(wp), parameter :: TCr = 385.05_wp + 273.15_wp !< Critical water temperature - real(wp), parameter :: mixM = 1.0e-8_wp !< threshold for 'mixture cell'. If Y < mixM, phase change does not happen - integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid - integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid + integer, parameter :: max_iter = 1e8_wp !< max # of iterations + real(wp), parameter :: pCr = 4.94e7_wp ! Critical pressure of water [Pa] + real(wp), parameter :: TCr = 385.05_wp + 273.15_wp ! Critical temperature of water [K] + real(wp), parameter :: mixM = 1.0e-8_wp ! Mixture mass fraction threshold for triggering phase change + integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid + integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid !> @} !> @name Gibbs free energy phase change parameters @@ -54,7 +54,9 @@ contains !! selecting the phase change module that will be used (pT- or pTg-equilibrium) impure subroutine s_initialize_phasechange_module - ! variables used in the calculation of the saturation curves for fluids 1 and 2 + ! Saturation curve coefficients derived from Clausius-Clapeyron relation via stiffened gas EOS. Saurel et al. JCP (2008), Le + ! Metayer et al. JFE (2004) gs_min = gamma-1, cvs = specific heat at constant volume, qvps = reference entropy, qvs = + ! reference energy A = (gs_min(lp)*cvs(lp) - gs_min(vp)*cvs(vp) + qvps(vp) - qvps(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) B = (qvs(lp) - qvs(vp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index e2f996c9f3..7cddb91a13 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -566,6 +566,8 @@ contains #endif end if + ! Recover primitive variables from relativistic MHD conserved variables via Newton-Raphson iteration on total + ! enthalpy W. Mignone & Bodo A&A (2006) W = total enthalpy, Ga = Lorentz factor, B2 = |B|^2, m2 = |m|^2, S = m.B if (relativity) then if (n == 0) then B(1) = Bx0 @@ -602,8 +604,10 @@ contains W = E + D $:GPU_LOOP(parallelism='[seq]') do iter = 1, relativity_cons_to_prim_max_iter + ! Lorentz factor from total enthalpy and magnetic field Ga = (W + B2)*W/sqrt((W + B2)**2*W**2 - (m2*W**2 + S**2*(2*W + B2))) - pres = (W - D*Ga)/((gamma_K + 1)*Ga**2) ! Thermal pressure from EOS + ! Thermal pressure from EOS + pres = (W - D*Ga)/((gamma_K + 1)*Ga**2) f = W - pres + (1 - 1/(2*Ga**2))*B2 - S**2/(2*W**2) - E - D ! The first equation below corrects a typo in (Mignone & Bodo, 2006) m2*W**2 -> 2*m2*W**2, which would @@ -617,7 +621,7 @@ contains dW = -f/df_dW W = W + dW - if (abs(dW) < 1.e-12_wp*W) exit + if (abs(dW) < 1.e-12_wp*W) exit ! Relative convergence criterion end do ! Recalculate pressure using converged W @@ -1294,21 +1298,20 @@ contains real(wp) :: blkmod1, blkmod2 integer :: q - if (chemistry) then + if (chemistry) then ! Reacting mixture sound speed if (avg_state == 1 .and. abs(c_c) > verysmall) then c = sqrt(c_c - (gamma - 1.0_wp)*(vel_sum - H)) else c = sqrt((1.0_wp + 1.0_wp/gamma)*pres/rho) end if - else if (relativity) then - ! Only supports perfect gas for now + else if (relativity) then ! Relativistic sound speed c = sqrt((1._wp + 1._wp/gamma)*pres/rho/H) else - if (alt_soundspeed) then + if (alt_soundspeed) then ! Wood's mixture sound speed via bulk moduli blkmod1 = ((gammas(1) + 1._wp)*pres + pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1._wp)*pres + pi_infs(2))/gammas(2) c = (1._wp/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) - else if (model_eqns == 3) then + else if (model_eqns == 3) then ! Six-equation model sound speed c = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, num_fluids diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 11ef1d543e..9821957777 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -222,7 +222,7 @@ contains end subroutine s_derive_flux_limiter - !> Computes the solution to the linear system Ax=b w/ sol = x + !> Solve Ax=b via Gaussian elimination with partial pivoting !! @param A Input matrix !! @param b right-hand-side !! @param sol Solution @@ -365,7 +365,7 @@ contains end do end do - ! Decompose J into asymmetric matrix, S, and a skew-symmetric matrix, O + ! Decompose velocity gradient into symmetric strain-rate S and skew-symmetric rotation-rate O do jj = 1, 3 do kk = 1, 3 S(jj, kk) = 0.5_wp*(q_jacobian_sf(jj, kk) + q_jacobian_sf(kk, jj)) @@ -380,8 +380,10 @@ contains end do end do + ! Q-criterion: Q = (||O||^2 - ||S||^2)/2, Hunt et al. CTR (1988) Q = 0.5_wp*((O2(1, 1) + O2(2, 2) + O2(3, 3)) - (S2(1, 1) + S2(2, 2) + S2(3, 3))) trS = S(1, 1) + S(2, 2) + S(3, 3) + ! Second invariant of strain-rate tensor IIS = 0.5_wp*((S(1, 1) + S(2, 2) + S(3, 3))**2 - (S2(1, 1) + S2(2, 2) + S2(3, 3))) q_sf(j, k, l) = Q + IIS end do @@ -395,6 +397,8 @@ contains !! @param q_prim_vf Primitive variables impure subroutine s_derive_liutex(q_prim_vf, liutex_mag, liutex_axis) + ! Liutex vortex identification via real eigenvector of velocity gradient, Xu et al. PoF (2019) + integer, parameter :: nm = 3 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -445,7 +449,7 @@ contains call dgeev(ivl, ivr, nm, vgt, nm, lr, li, vl, nm, vr, nm, work, lwork, info) #endif - ! Find real eigenvector + ! Find eigenvector with smallest imaginary eigenvalue (real eigenvector of VGT) idx = 1 do r = 2, 3 if (abs(li(r)) < abs(li(idx))) then @@ -472,11 +476,12 @@ contains omega_proj = -omega_proj end if - ! Find imaginary part of complex eigenvalue + ! Imaginary eigenvalue of the complex conjugate pair (cyclic index selection) lci = li(mod(idx, 3) + 1) - ! Compute Liutex magnitude - alpha = omega_proj**2._wp - 4._wp*lci**2._wp ! (2*alpha)^2 + ! Discriminant: determines whether rotation dominates strain + alpha = omega_proj**2._wp - 4._wp*lci**2._wp + ! Liutex magnitude = omega_proj - sqrt(discriminant) when rotation dominates if (alpha > 0._wp) then liutex_mag(j, k, l) = omega_proj - sqrt(alpha) else diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 1985fbd040..1aa96e7947 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -331,6 +331,7 @@ contains do j = 0, n do i = 0, m if (patch_icpp(patch_id)%smoothen) then + ! Smooth Heaviside via hyperbolic tangent; smooth_coeff controls interface sharpness eta = tanh(smooth_coeff/min(dx, & & dy)*(sqrt((x_cc(i) - x_centroid)**2 + (y_cc(j) - y_centroid)**2) - radius))*(-0.5_wp) + 0.5_wp end if diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 03b1a9604b..03d7aca075 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -75,7 +75,8 @@ contains end function f_rddot - !> Function that computes that bubble wall pressure for Gilmore bubbles + !> Bubble wall pressure: stiffened gas with Laplace pressure and viscous stress Ca = cavitation number, Web = Weber number, + !! Re_inv = inverse Reynolds number Rayleigh PRSLA (1917), Plesset JAM (1949), Keller-Miksis JASA (1980) !! @param fR0 Equilibrium bubble radius !! @param fR Current bubble radius !! @param fV Current bubble velocity @@ -161,7 +162,7 @@ contains end function f_cpinfdot - !> Function that computes the time derivative of the enthalpy + !> Enthalpy derivative for Gilmore bubble model, Gilmore (1952) !! @param fCpbw Bubble wall pressure !! @param fCpinf Driving bubble pressure !! @param fCpinf_dot Time derivative of the driving pressure @@ -192,7 +193,7 @@ contains end function f_Hdot - !> Function that computes the bubble radial acceleration for Rayleigh-Plesset bubbles + !> Rayleigh-Plesset bubble radial acceleration !! @param fCp Driving pressure !! @param fRho Current density !! @param fR Current bubble radius @@ -256,7 +257,7 @@ contains end function f_cpbw_KM - !> Function that computes the bubble radial acceleration for Keller--Miksis bubbles + !> Keller-Miksis bubble radial acceleration !! @param fpbdot Time-derivative of internal bubble pressure !! @param fCp Driving pressure !! @param fCpbw Bubble wall pressure diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 98d4691174..41b34074e4 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -496,7 +496,7 @@ contains !> The following is the implementation of the CBC based on the work of Thompson (1987, 1990) on hyperbolic systems. The CBC is !! indirectly applied in the computation of the right-hand-side (RHS) near the relevant domain boundary through the modification - !! of the fluxes. + !! of the fluxes. Characteristic boundary conditions, Thompson JCP (1987, 1990) !! @param q_prim_vf Cell-average primitive variables !! @param flux_vf Cell-boundary-average fluxes !! @param flux_src_vf Cell-boundary-average flux sources diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index e1a252a6bf..35edc1d0e1 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -217,7 +217,7 @@ contains ! tensor is the symmetric tensor & calculate the trace of the tensor trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) - ! calculate the deviatoric of the tensor + ! Deviatoric left Cauchy-Green tensor: dev(b) = b - (tr(b)/3)*I #:for IJ in [1,3,6] btensor_in(${IJ}$)%sf(j, k, l) = btensor_in(${IJ}$)%sf(j, k, l) - f13*trace #:endfor @@ -226,7 +226,7 @@ contains do i = 1, b_size - 1 q_prim_vf(strxb + i - 1)%sf(j, k, l) = G_param*btensor_in(i)%sf(j, k, l)/btensor_in(b_size)%sf(j, k, l) end do - ! compute the invariant without the elastic modulus + ! First invariant strain energy: W = G/2 * (I1 - 3), neo-Hookean model q_prim_vf(xiend + 1)%sf(j, k, l) = 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) end subroutine s_neoHookean_cauchy_solver @@ -253,7 +253,7 @@ contains ! TODO Make this 1D and 2D capable tensor is the symmetric tensor & calculate the trace of the tensor trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) - ! calculate the deviatoric of the tensor + ! Deviatoric left Cauchy-Green tensor: dev(b) = b - (tr(b)/3)*I btensor_in(1)%sf(j, k, l) = btensor_in(1)%sf(j, k, l) - f13*trace btensor_in(3)%sf(j, k, l) = btensor_in(3)%sf(j, k, l) - f13*trace btensor_in(6)%sf(j, k, l) = btensor_in(6)%sf(j, k, l) - f13*trace @@ -263,7 +263,7 @@ contains do i = 1, b_size - 1 q_prim_vf(strxb + i - 1)%sf(j, k, l) = G_param*btensor_in(i)%sf(j, k, l)/btensor_in(b_size)%sf(j, k, l) end do - ! compute the invariant without the elastic modulus + ! First invariant strain energy: W = G/2 * (I1 - 3), neo-Hookean model q_prim_vf(xiend + 1)%sf(j, k, l) = 0.5_wp*(trace - 3.0_wp)/btensor_in(b_size)%sf(j, k, l) end subroutine s_Mooney_Rivlin_cauchy_solver diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index 825e1a9145..b3b6c907c5 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -194,6 +194,7 @@ contains G_K = G_K + q_prim_vf(advxb - 1 + i)%sf(k, l, q)*Gs_hypo(i) ! alpha_K(1) * Gs_hypo(1) end do + ! Continuum damage: (1-D) scales effective stiffness, D in [0,1] if (cont_damage) G_K = G_K*max((1._wp - q_prim_vf(damage_idx)%sf(k, l, q)), 0._wp) rho_K_field(k, l, q) = rho_K diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 9e2631937a..3f89eb6d94 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -111,6 +111,9 @@ contains @:ALLOCATE(ghost_points(1:max_num_gps)) $:GPU_ENTER_DATA(copyin='[ghost_points]') + ! Ghost-cell immersed boundary method procedure: 1. Identify ghost points adjacent to IB surface 2. Apply levelset to + ! determine inside/outside 3. Compute image points (reflection across IB surface) 4. Interpolate flow variables at image + ! points Tseng & Ferziger JCP (2003), Mittal & Iaccarino ARFM (2005) call s_find_ghost_points(ghost_points) call s_apply_levelset(ghost_points, num_gps) @@ -241,8 +244,7 @@ contains q_prim_vf(E_idx)%sf(j, k, l) = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, num_fluids - ! Set the pressure inside a moving immersed boundary based upon the pressure of the image point. - ! acceleration, and normal vector direction + ! Pressure correction for moving IB: accounts for acceleration of IB surface q_prim_vf(E_idx)%sf(j, k, l) = q_prim_vf(E_idx)%sf(j, k, & & l) + pres_IP/(1._wp - 2._wp*abs(gp%levelset*alpha_rho_IP(q)/pres_IP) & & *dot_product(patch_ib(patch_id) %force/patch_ib(patch_id)%mass, gp%levelset_norm)) diff --git a/src/simulation/m_pressure_relaxation.fpp b/src/simulation/m_pressure_relaxation.fpp index 3d77f35a6e..eae3e1c10d 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -148,7 +148,8 @@ contains #:else real(wp), dimension(num_fluids) :: pres_K_init, rho_K_s #:endif - integer, parameter :: MAX_ITER = 50 + integer, parameter :: MAX_ITER = 50 + ! Pressure relaxation convergence tolerance real(wp), parameter :: TOLERANCE = 1.e-10_wp integer :: iter, i @@ -186,6 +187,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids if (q_cons_vf(i + advxb - 1)%sf(j, k, l) > sgm_eps) then + ! Isentropic relation: rho = rho0 * (p/p0)^(1/gamma), Saurel et al. JFM (2009) rho_K_s(i) = q_cons_vf(i + contxb - 1)%sf(j, k, l)/max(q_cons_vf(i + advxb - 1)%sf(j, k, l), & & sgm_eps)*((pres_relax + ps_inf(i))/(pres_K_init(i) + ps_inf(i)))**(1._wp/gs_min(i)) f_pres = f_pres + q_cons_vf(i + contxb - 1)%sf(j, k, l)/rho_K_s(i) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 464468f83f..495be4b929 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -524,6 +524,7 @@ contains 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 longitudinal wave speed: sqrt(c^2 + (4G/3 + tau_e)/rho), 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))) & @@ -543,7 +544,7 @@ contains end if if (hyper_cleaning) then - ! Dedner GLM: (B_n, psi) subsystem has eigenvalues +/- c_h in the lab frame. + ! 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 @@ -556,6 +557,7 @@ contains 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))))) @@ -2022,6 +2024,8 @@ contains ! COMPUTING THE DIRECT WAVE SPEEDS if (wave_speeds == 1) then if (elasticity) then + ! Elastic longitudinal wave speed: sqrt(c^2 + (4G/3 + tau_e)/rho), 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) & @@ -2046,6 +2050,7 @@ contains 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))))) @@ -2329,6 +2334,7 @@ contains 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))))) @@ -2680,6 +2686,7 @@ contains 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))))) @@ -3091,6 +3098,8 @@ contains if (wave_speeds == 1) then if (elasticity) then + ! Elastic longitudinal wave speed: sqrt(c^2 + (4G/3 + tau_e)/rho), 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) & @@ -3115,6 +3124,7 @@ contains 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))))) diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index ab7081533a..446988476b 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -118,6 +118,7 @@ contains & l, i) end do + ! Continuum surface force capillary stress, Schmidmayer et al. JCP (2017) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) + sigma*c_divs(num_dims + 1)%sf(j, k, & & l)*vSrc_rsx_vf(j, k, l, 1) end if @@ -159,6 +160,7 @@ contains & j, l, i) end do + ! Continuum surface force capillary stress, Schmidmayer et al. JCP (2017) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsy_vf(k, j, l, 2) end if @@ -201,6 +203,7 @@ contains & k, j, i) end do + ! Continuum surface force capillary stress, Schmidmayer et al. JCP (2017) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsz_vf(l, k, j, 3) end if diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index aaba3cfd67..6bbce83175 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -1458,11 +1458,12 @@ contains real(wp) :: d_MD, d_LC !< Median (md) curvature and large curvature (LC) measures ! The left and right upper bounds (UL), medians, large curvatures, minima, and maxima of the WENO-reconstructed values of ! the cell- average variables. - real(wp) :: vL_UL, vR_UL - real(wp) :: vL_MD, vR_MD - real(wp) :: vL_LC, vR_LC - real(wp) :: vL_min, vR_min - real(wp) :: vL_max, vR_max + real(wp) :: vL_UL, vR_UL + real(wp) :: vL_MD, vR_MD + real(wp) :: vL_LC, vR_LC + real(wp) :: vL_min, vR_min + real(wp) :: vL_max, vR_max + ! Monotonicity-preserving bounds, Suresh & Huynh JCP (1997) real(wp), parameter :: alpha = 2._wp !> !! Determines the maximum Courant-Friedrichs-Lewy (CFL) number that may be utilized with the scheme. In theory, for !! stability, a CFL number less than 1/(1+alpha) is necessary. The default value for alpha is 2. @@ -1478,10 +1479,12 @@ contains do k = is2_weno%beg, is2_weno%end do j = is1_weno%beg, is1_weno%end do i = 1, v_size + ! Second-order undivided differences for curvature estimation d(-1) = v_rs_ws(j, k, l, i) + v_rs_ws(j - 2, k, l, i) - v_rs_ws(j - 1, k, l, i)*2._wp d(0) = v_rs_ws(j + 1, k, l, i) + v_rs_ws(j - 1, k, l, i) - v_rs_ws(j, k, l, i)*2._wp d(1) = v_rs_ws(j + 2, k, l, i) + v_rs_ws(j, k, l, i) - v_rs_ws(j + 1, k, l, i)*2._wp + ! Median function for oscillation detection Fourth-order curvature limiter (Eq. 2.12 in Suresh & Huynh) d_MD = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1)))*abs((sign(1._wp, & & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp From 9be1d1264e62882642a7e810c746f24c91270ed7 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 01:46:01 -0400 Subject: [PATCH 15/25] Add documentation: model branch labels, solver references, algorithm descriptions --- src/common/m_boundary_common.fpp | 2 +- src/common/m_variables_conversion.fpp | 28 ++++++++++----- src/pre_process/m_grid.f90 | 11 ++++-- src/simulation/m_acoustic_src.fpp | 7 ++-- src/simulation/m_rhs.fpp | 9 +++-- src/simulation/m_riemann_solvers.fpp | 51 ++++++++++++++------------- src/simulation/m_viscous.fpp | 10 +++--- src/simulation/m_weno.fpp | 10 +++++- 8 files changed, 82 insertions(+), 46 deletions(-) diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 6563e55379..b95c02ce5b 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -79,7 +79,7 @@ contains type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type integer :: k, l - ! Population of Buffers in x-direction + ! BC type codes defined in m_constants.fpp; non-negative values are MPI boundaries if (bc_x%beg >= 0) then call s_mpi_sendrecv_variables_buffers(q_prim_vf, 1, -1, sys_size, pb_in, mv_in) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 7cddb91a13..cb0f54ec08 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -127,17 +127,21 @@ contains ! procedure pointer if (mhd) then + ! MHD pressure: subtract magnetic pressure from total energy pres = (energy - dyn_p - pi_inf - qv - pres_mag)/gamma else if ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then + ! Gamma/pi_inf model or five-equation model (Allaire et al. JCP 2002): p from mixture EOS pres = (energy - dyn_p - pi_inf - qv)/gamma else if ((model_eqns /= 4) .and. bubbles_euler) then + ! Bubble-augmented pressure with void fraction correction pres = ((energy - dyn_p)/(1._wp - alf) - pi_inf - qv)/gamma else + ! Four-equation model (Kapila et al. PoF 2001): Tait EOS inversion pres = (pref + pi_inf)*(energy/(rhoref*(1 - alf)))**(1/gamma + 1) - pi_inf end if if (hypoelasticity .and. present(G)) then - ! calculate elastic contribution to Energy + ! Subtract elastic strain energy before computing pressure (hypoelastic model) E_e = 0._wp do s = stress_idx%beg, stress_idx%end if (G > 0) then @@ -152,6 +156,7 @@ contains pres = (energy - 0.5_wp*(mom**2._wp)/rho - pi_inf - qv - E_e)/gamma end if #:else + ! Reacting mixture pressure from temperature and species Y_rs(:) = rhoYks(:)/rho e_Per_Kg = energy/rho Pdyn_Per_Kg = dyn_p/rho @@ -496,7 +501,8 @@ contains end subroutine s_initialize_pb - !> The following procedure handles the conversion between the conservative variables and the primitive variables. + !> Convert conserved variables (rho*alpha, rho*u, E, alpha) to primitives (rho, u, p, alpha). Conversion depends on model_eqns: + !! each model has different variable sets and EOS. !! @param qK_cons_vf Conservative variables !! @param q_T_sf Temperature scalar field !! @param qK_prim_vf Primitive variables @@ -644,6 +650,7 @@ contains end if if (chemistry) then + ! Reacting flow: recover density from species partial densities, compute mass fractions Y_k = rhoY_k / rho rho_K = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = chemxb, chemxe @@ -660,6 +667,7 @@ contains qK_prim_vf(i)%sf(j, k, l) = max(0._wp, qK_cons_vf(i)%sf(j, k, l)/rho_K) end do else + ! Non-reacting: partial densities are directly primitive (alpha_i * rho_i) $:GPU_LOOP(parallelism='[seq]') do i = 1, contxe qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) @@ -670,12 +678,14 @@ contains rho_K = max(rho_K, sgm_eps) #endif + ! Recover velocity from momentum: u = rho*u / rho, and accumulate dynamic pressure 0.5*rho*|u|^2 $:GPU_LOOP(parallelism='[seq]') do i = momxb, momxe if (model_eqns /= 4) then qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/rho_K dyn_pres_K = dyn_pres_K + 5.e-1_wp*qK_cons_vf(i)%sf(j, k, l)*qK_prim_vf(i)%sf(j, k, l) else + ! Four-equation model (Kapila et al. PoF 2001): divide by total density q_cons(1) qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/qK_cons_vf(1)%sf(j, k, l) end if end do @@ -711,6 +721,7 @@ contains end if if (bubbles_euler) then + ! Recover bubble primitive variables: divide conserved moments by bubble number density $:GPU_LOOP(parallelism='[seq]') do i = 1, nb nRtmp(i) = qK_cons_vf(bubrs_vc(i))%sf(j, k, l) @@ -808,7 +819,7 @@ contains end subroutine s_convert_conservative_to_primitive_variables - !> The following procedure handles the conversion between the primitive variables and the conservative variables. + !> Convert primitives (rho, u, p, alpha) to conserved variables (rho*alpha, rho*u, E, alpha). !! @param q_prim_vf Primitive variables !! @param q_cons_vf Conservative variables impure subroutine s_convert_primitive_to_conservative_variables(q_prim_vf, q_cons_vf) @@ -925,6 +936,7 @@ contains end do if (chemistry) then + ! Reacting mixture: compute conserved energy from species mass fractions and temperature do i = chemxb, chemxe Ys(i - chemxb + 1) = q_prim_vf(i)%sf(j, k, l) q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) @@ -945,24 +957,24 @@ contains pres_mag = 0.5_wp*(q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, & & l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) end if + ! MHD energy includes magnetic pressure contribution q_cons_vf(E_idx)%sf(j, k, l) = gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pres_mag + pi_inf + qv else if ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then - ! E = Gamma*P + \rho u u /2 + \pi_inf + (\alpha\rho qv) + ! Five-equation model (Allaire et al. JCP 2002): E = Gamma*p + 0.5*rho*|u|^2 + pi_inf + qv q_cons_vf(E_idx)%sf(j, k, l) = gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pi_inf + qv else if ((model_eqns /= 4) .and. (bubbles_euler)) then - ! \tilde{E} = dyn_pres + (1-\alf)(\Gamma p_l + \Pi_inf) + ! Bubble-augmented energy with void fraction correction q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + (1._wp - q_prim_vf(alf_idx)%sf(j, k, & & l))*(gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) else - ! Tait EOS, no conserved energy variable + ! Four-equation model (Kapila et al. PoF 2001): Tait EOS, no conserved energy variable q_cons_vf(E_idx)%sf(j, k, l) = 0._wp end if end if - ! Computing the internal energies from the pressure and continuities + ! Six-equation model (Saurel et al. JCP 2009): compute per-phase internal energies if (model_eqns == 3) then do i = 1, num_fluids - ! internal energy calculation for each of the fluids q_cons_vf(i + intxb - 1)%sf(j, k, l) = q_cons_vf(i + advxb - 1)%sf(j, k, & & l)*(gammas(i)*q_prim_vf(E_idx)%sf(j, k, & & l) + pi_infs(i)) + q_cons_vf(i + contxb - 1)%sf(j, k, l)*qvs(i) diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index b0b673a579..49f45f5faf 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -38,7 +38,7 @@ impure subroutine s_generate_serial_grid ! Generic loop iterator integer :: i, j !< generic loop operators real(wp) :: length !< domain lengths - ! Grid Generation in the x-direction + ! Uniform grid: dx = (x_end - x_beg) / (m + 1) dx = (x_domain%end - x_domain%beg)/real(m + 1, wp) @@ -49,6 +49,7 @@ impure subroutine s_generate_serial_grid x_cb(m) = x_domain%end + ! Hyperbolic tangent grid stretching if (stretch_x) then length = abs(x_cb(m) - x_cb(-1)) x_cb = x_cb/length @@ -73,8 +74,8 @@ impure subroutine s_generate_serial_grid ! Grid Generation in the y-direction if (n == 0) return + ! Axisymmetric cylindrical grid (r, z): half-cell offset at r=0 axis if (grid_geometry == 2 .and. f_approx_equal(y_domain%beg, 0.0_wp)) then - ! IF (grid_geometry == 2) THEN dy = (y_domain%end - y_domain%beg)/real(2*n + 1, wp) y_cc(0) = y_domain%beg + 5.e-1_wp*dy @@ -95,6 +96,7 @@ impure subroutine s_generate_serial_grid y_cb(n) = y_domain%end + ! Hyperbolic tangent grid stretching in y-direction if (stretch_y) then length = abs(y_cb(n) - y_cb(-1)) y_cb = y_cb/length @@ -128,6 +130,7 @@ impure subroutine s_generate_serial_grid z_cb(p) = z_domain%end + ! Hyperbolic tangent grid stretching in z-direction if (stretch_z) then length = abs(z_cb(p) - z_cb(-1)) z_cb = z_cb/length @@ -169,12 +172,13 @@ impure subroutine s_generate_parallel_grid allocate (y_cb_glb(-1:n_glb)) allocate (z_cb_glb(-1:p_glb)) - ! Grid generation in the x-direction + ! Uniform grid: dx = (x_end - x_beg) / (m_glb + 1) dx = (x_domain%end - x_domain%beg)/real(m_glb + 1, wp) do i = 0, m_glb x_cb_glb(i - 1) = x_domain%beg + dx*real(i, wp) end do x_cb_glb(m_glb) = x_domain%end + ! Hyperbolic tangent grid stretching in x-direction (parallel version) if (stretch_x) then length = abs(x_cb_glb(m_glb) - x_cb_glb(-1)) @@ -195,6 +199,7 @@ impure subroutine s_generate_parallel_grid ! Grid generation in the y-direction if (n_glb > 0) then + ! Axisymmetric cylindrical grid (r, z): half-cell offset at r=0 axis if (grid_geometry == 2 .and. f_approx_equal(y_domain%beg, 0.0_wp)) then dy = (y_domain%end - y_domain%beg)/real(2*n_glb + 1, wp) y_cb_glb(-1) = y_domain%beg diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 6da3831291..04351aed0e 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -4,7 +4,8 @@ #:include 'macros.fpp' -!> @brief Applies acoustic pressure source terms including focused, planar, and broadband transducers +!> @brief One-way acoustic source injection following Maeda and Colonius, JCP 2017. Supports planar, focused transducer, transducer +!! array, and broadband waveforms. module m_acoustic_src use m_derived_types !< Definitions of the derived types @@ -363,6 +364,7 @@ contains source = 0._wp + ! Temporal waveform: sine, Gaussian pulse, square wave, or broadband if (pulse(ai) == 1) then ! Sine wave if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return @@ -396,7 +398,7 @@ contains end subroutine s_source_temporal - !> This subroutine identifies and precalculates the non-zero acoustic spatial sources before time-stepping + !> Pre-compute non-zero spatial source weights before time-stepping impure subroutine s_precalculate_acoustic_spatial_sources integer :: j, k, l, ai @@ -540,6 +542,7 @@ contains source = 0._wp + ! Gaussian spatial pulse profile: exp(-0.5 * (d / sigma)^2) / (sqrt(2*pi) * sigma) if (support(ai) == 1) then ! 1D source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(r(1)/(sig/2._wp))**2._wp) else if (support(ai) == 2 .or. support(ai) == 3) then ! 2D or 3D diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 6c5f5cf719..f77e83bfdf 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -561,6 +561,9 @@ contains real(wp) :: t_start, t_finish integer :: id integer(kind=8) :: i, j, k, l, q !< Generic loop iterators + + ! RHS: halo exchange -> reconstruct -> Riemann solve -> flux difference -> source terms + call nvtxStartRange("COMPUTE-RHS") call cpu_time(t_start) @@ -645,7 +648,7 @@ contains call nvtxEndRange end if - ! Dimensional Splitting Loop + ! Loop over coordinate directions for dimensional splitting do id = 1, num_dims if (igr .or. dummy) then if (id == 1) then @@ -785,7 +788,7 @@ contains call nvtxEndRange end if - ! RHS additions for viscosity + ! Viscous stress contribution to RHS if (viscous .or. surface_tension .or. chem_params%diffusion) then call nvtxStartRange("RHS-ADD-PHYSICS") call s_compute_additional_physics_rhs(id, q_prim_qp%vf, rhs_vf, flux_src_n(id)%vf, dq_prim_dx_qp(1)%vf, & @@ -793,7 +796,7 @@ contains call nvtxEndRange end if - ! RHS additions for sub-grid bubbles_euler + ! Bubble dynamics source terms if (bubbles_euler) then call nvtxStartRange("RHS-BUBBLES-COMPUTE") call s_compute_bubbles_EE_rhs(id, q_prim_qp%vf, divu) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 495be4b929..626606feac 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -158,7 +158,7 @@ contains end subroutine s_compute_viscous_source_flux - !> @brief Computes intercell fluxes using the Harten-Lax-van Leer (HLL) approximate Riemann solver. + ! HLL approximate Riemann solver, Harten et al. SIAM Review (1983) subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & @@ -519,8 +519,10 @@ contains end do end if + ! Wave speed estimates (wave_speeds=1: direct, wave_speeds=2: pressure-based) if (wave_speeds == 1) 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 @@ -578,7 +580,7 @@ contains 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)) - ! Low Mach correction + ! 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 @@ -708,7 +710,7 @@ contains end do end if - ! Advection + ! Advection flux and source: interface velocity for volume fraction transport $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = (qL_prim_rs${XYZ}$_vf(j, k, l, i) - qR_prim_rs${XYZ}$_vf(j + 1, & @@ -737,6 +739,7 @@ contains 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 @@ -833,7 +836,7 @@ contains end subroutine s_hll_riemann_solver - !> @brief Computes intercell fluxes using the Lax-Friedrichs (LF) approximate Riemann solver. + ! Lax-Friedrichs (Rusanov) approximate Riemann solver subroutine s_lf_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & @@ -1323,7 +1326,7 @@ contains end do end if - ! Advection + ! Advection flux and source: interface velocity for volume fraction transport $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = (qL_prim_rs${XYZ}$_vf(j, k, l, i) - qR_prim_rs${XYZ}$_vf(j + 1, & @@ -1352,6 +1355,7 @@ contains 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 @@ -1701,9 +1705,7 @@ contains end subroutine s_lf_riemann_solver - !> This procedure is the implementation of the Harten, Lax, van Leer, and contact (HLLC) approximate Riemann solver, see Toro - !! (1999) and Johnsen (2007). The viscous and the surface tension effects have been included by modifying the exact Riemann - !! solver of Perigaud and Saurel (2005). + ! HLLC Riemann solver with contact restoration, Toro et al. Shock Waves (1994) !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) @@ -1830,9 +1832,9 @@ contains #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (norm_dir == ${NORM_DIR}$) then - ! 6-EQUATION MODEL WITH HLLC + ! 6-EQUATION MODEL WITH HLLC HLLC star-state flux with contact wave speed s_S if (model_eqns == 3) then - ! ME3 + ! 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, & @@ -1967,7 +1969,7 @@ contains end do end if - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY + ! Hyperelastic stress contribution: strain energy added to total energy if (hyperelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -2144,7 +2146,7 @@ contains & i)*s_S + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S end do - ! SOURCE TERM FOR VOLUME FRACTION ADVECTION FLUX. + ! Advection velocity source: interface velocity for volume fraction transport $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, & @@ -2187,7 +2189,7 @@ contains end do end if - ! REFERENCE MAP FLUX. + ! Hyperelastic reference map flux for material deformation tracking if (hyperelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -2243,7 +2245,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() else if (model_eqns == 4) then - ! ME4 + ! 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, & @@ -2397,7 +2399,7 @@ contains & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do - ! Source for volume fraction advection equation + ! Advection velocity source: interface velocity for volume fraction transport $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp @@ -2462,6 +2464,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() else if (model_eqns == 2 .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, & @@ -2776,7 +2779,7 @@ contains & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end do - ! Source for volume fraction advection equation + ! Advection velocity source: interface velocity for volume fraction transport $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims vel_src_rs${XYZ}$_vf(j, k, l, & @@ -2855,7 +2858,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() else - ! 5-EQUATION MODEL WITH HLLC + ! 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, & @@ -3038,7 +3041,7 @@ contains end do end if - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY + ! Hyperelastic stress contribution: strain energy added to total energy if (hyperelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -3240,7 +3243,7 @@ contains & c_idx)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) end if - ! REFERENCE MAP FLUX. + ! Hyperelastic reference map flux for material deformation tracking if (hyperelasticity) then $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims @@ -3340,7 +3343,7 @@ contains end subroutine s_hllc_riemann_solver - !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: 1 entropy wave, 2 Alfven waves, 2 fast magnetosonic waves. + ! HLLD Riemann solver for MHD, Miyoshi & Kusano JCP (2005) subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & @@ -3512,13 +3515,13 @@ contains F_R(3:4) = U_R(2)*vel%R(2:3) - B%R(1)*B%R(2:3) F_R(5:6) = vel%R(1)*B%R(2:3) - vel%R(2:3)*B%R(1) F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) - ! Compute the star flux using HLL relation + ! 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) - ! Compute the rotational (Alfven) speeds + ! 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) - ! Compute the double-star states [Miyoshi Eqns. (59)-(62)] + ! 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) @@ -3544,7 +3547,7 @@ contains U_doubleR = [rhoR_star, rhoR_star*s_M, rhoR_star*v_double, rhoR_star*w_double, By_double, Bz_double, & & E_double] - ! (11) Choose HLLD flux based on wave-speed regions + ! Select HLLD flux from the 5 wave-speed regions: L, *L, **L/**R, *R, R if (0.0_wp <= s_L) then F_hlld = F_L else if (0.0_wp <= s_starL) then diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index d511249bcb..952c7aa7e6 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -166,10 +166,12 @@ contains end if end if + ! Shear stress near cylindrical axis: includes v/r hoop term tau_Re(2, 1) = (grad_y_vf(1)%sf(j, k, l) + grad_x_vf(2)%sf(j, k, l))/Re_visc(1) tau_Re(2, 2) = (4._wp*grad_y_vf(2)%sf(j, k, l) - 2._wp*grad_x_vf(1)%sf(j, k, & & l) - 2._wp*q_prim_vf(momxb + 1)%sf(j, k, l)/y_cc(k))/(3._wp*Re_visc(1)) + ! Viscous flux contribution to momentum and energy equations $:GPU_LOOP(parallelism='[seq]') do i = 1, 2 tau_Re_vf(contxe + i)%sf(j, k, l) = tau_Re_vf(contxe + i)%sf(j, k, l) - tau_Re(2, i) @@ -527,7 +529,7 @@ contains end do if (weno_Re_flux) then - ! Compute velocity gradient at cell centers using scalar divergence theorem + ! Compute velocity gradients via divergence theorem on cell-boundary reconstructed values do i = 1, num_dims if (i == 1) then call s_apply_scalar_divergence_theorem(qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), & @@ -543,7 +545,7 @@ contains & buff_size) end if end do - else ! Compute velocity gradient at cell centers using finite differences + else ! Compute velocity gradients at cell centers using central finite differences iv%beg = mom_idx%beg; iv%end = mom_idx%end $:GPU_UPDATE(device='[iv]') @@ -1373,14 +1375,14 @@ contains divergence = divergence + velocity_gradient_tensor(l, l) end do - ! set up the shear stress tensor + ! Viscous stress tensor: tau_ij = mu * (du_i/dx_j + du_j/dx_i) - 2/3 * mu * div(u) * delta_ij do l = 1, num_dims do q = 1, num_dims viscous_stress_tensor(l, q) = dynamic_viscosity*(velocity_gradient_tensor(l, q) + velocity_gradient_tensor(q, l)) end do end do - ! populate the viscous_stress_tensor + ! Subtract isotropic bulk viscosity term (Stokes hypothesis) do l = 1, num_dims viscous_stress_tensor(l, l) = viscous_stress_tensor(l, l) - 2._wp*divergence*dynamic_viscosity/3._wp end do diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 6bbce83175..b85e750307 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -176,6 +176,8 @@ contains !! @param is Index bounds in the s-direction subroutine s_compute_weno_coefficients(weno_dir, is) + ! Compute WENO coefficients for a given coordinate direction. Shu (1997) + integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is integer :: s @@ -200,18 +202,21 @@ contains if (weno_dir == ${WENO_DIR}$) then if (weno_order == 3) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn + ! Polynomial reconstruction coefficients poly_coef_cbR_${XYZ}$ (i + 1, 0, 0) = (s_cb(i) - s_cb(i + 1))/(s_cb(i) - s_cb(i + 2)) poly_coef_cbR_${XYZ}$ (i + 1, 1, 0) = (s_cb(i) - s_cb(i + 1))/(s_cb(i - 1) - s_cb(i + 1)) poly_coef_cbL_${XYZ}$ (i + 1, 0, 0) = -poly_coef_cbR_${XYZ}$ (i + 1, 0, 0) poly_coef_cbL_${XYZ}$ (i + 1, 1, 0) = -poly_coef_cbR_${XYZ}$ (i + 1, 1, 0) + ! Ideal (linear) weights d_cbR_${XYZ}$ (0, i + 1) = (s_cb(i - 1) - s_cb(i + 1))/(s_cb(i - 1) - s_cb(i + 2)) d_cbL_${XYZ}$ (0, i + 1) = (s_cb(i - 1) - s_cb(i))/(s_cb(i - 1) - s_cb(i + 2)) d_cbR_${XYZ}$ (1, i + 1) = 1._wp - d_cbR_${XYZ}$ (0, i + 1) d_cbL_${XYZ}$ (1, i + 1) = 1._wp - d_cbL_${XYZ}$ (0, i + 1) + ! Smoothness indicator coefficients beta_coef_${XYZ}$ (i + 1, 0, 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp/(s_cb(i) - s_cb(i + 2))**2._wp beta_coef_${XYZ}$ (i + 1, 1, 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp/(s_cb(i - 1) - s_cb(i + 1))**2._wp end do @@ -234,6 +239,7 @@ contains ! Computing WENO5 Coefficients else if (weno_order == 5) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn + ! Polynomial reconstruction coefficients poly_coef_cbR_${XYZ}$ (i + 1, 0, & & 0) = ((s_cb(i) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i + 2)))/((s_cb(i) - s_cb(i & & + 3))*(s_cb(i + 3) - s_cb(i + 1))) @@ -272,6 +278,7 @@ contains & 0) = ((s_cb(i - 2) - s_cb(i)) + (s_cb(i - 1) - s_cb(i + 1)))/((s_cb(i - 2) & & - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))*((s_cb(i) - s_cb(i + 1))) + ! Ideal (linear) weights d_cbR_${XYZ}$ (0, & & i + 1) = ((s_cb(i - 2) - s_cb(i + 1))*(s_cb(i + 1) - s_cb(i - 1)))/((s_cb(i - 2) & & - s_cb(i + 3))*(s_cb(i + 3) - s_cb(i - 1))) @@ -288,6 +295,7 @@ contains d_cbR_${XYZ}$ (1, i + 1) = 1._wp - d_cbR_${XYZ}$ (0, i + 1) - d_cbR_${XYZ}$ (2, i + 1) d_cbL_${XYZ}$ (1, i + 1) = 1._wp - d_cbL_${XYZ}$ (0, i + 1) - d_cbL_${XYZ}$ (2, i + 1) + ! Smoothness indicator coefficients beta_coef_${XYZ}$ (i + 1, 0, & & 0) = 4._wp*(s_cb(i) - s_cb(i + 1))**2._wp*(10._wp*(s_cb(i + 1) - s_cb(i))**2._wp & & + (s_cb(i + 1) - s_cb(i))*(s_cb(i + 2) - s_cb(i + 1)) + (s_cb(i + 2) - s_cb(i + 1)) & @@ -1484,7 +1492,7 @@ contains d(0) = v_rs_ws(j + 1, k, l, i) + v_rs_ws(j - 1, k, l, i) - v_rs_ws(j, k, l, i)*2._wp d(1) = v_rs_ws(j + 2, k, l, i) + v_rs_ws(j, k, l, i) - v_rs_ws(j + 1, k, l, i)*2._wp - ! Median function for oscillation detection Fourth-order curvature limiter (Eq. 2.12 in Suresh & Huynh) + ! Median function for oscillation detection d_MD = (sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, 4._wp*d(0) - d(-1)))*abs((sign(1._wp, & & 4._wp*d(-1) - d(0)) + sign(1._wp, d(-1)))*(sign(1._wp, 4._wp*d(-1) - d(0)) + sign(1._wp, & & d(0))))*min(abs(4._wp*d(-1) - d(0)), abs(d(-1)), abs(4._wp*d(0) - d(-1)), abs(d(0)))/8._wp From 237f38afe37cea2f3d8b3e500f06a4ca18666013 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 01:53:13 -0400 Subject: [PATCH 16/25] Trim verbose paper references and remove duplicate comments --- src/common/m_helper.fpp | 6 +++--- src/common/m_phase_change.fpp | 4 +--- src/common/m_variables_conversion.fpp | 3 +-- src/simulation/m_acoustic_src.fpp | 3 +-- src/simulation/m_bubbles.fpp | 5 ++--- src/simulation/m_ibm.fpp | 4 +--- src/simulation/m_riemann_solvers.fpp | 8 +++----- src/simulation/m_surface_tension.fpp | 2 -- 8 files changed, 12 insertions(+), 23 deletions(-) diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index bfdeecc74f..976cd6ed15 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -174,7 +174,7 @@ contains integer :: ir real(wp), dimension(nb) :: chi_vw0, cp_m0, k_m0, rho_m0, x_vw, omegaN, rhol0 real(wp), parameter :: k_poly = 1._wp !< polytropic index used to compute isothermal natural frequency - ! Chapman-Enskog transport coefficients for vapor-gas mixture, Ando JAS (2010) Eq. 2.22 + ! Chapman-Enskog transport coefficients for vapor-gas mixture, Ando JAS (2010) phi_vg = (1._wp + sqrt(mu_v/mu_g)*(M_g/M_v)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_v/M_g)) phi_gv = (1._wp + sqrt(mu_g/mu_v)*(M_v/M_g)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_g/M_v)) @@ -182,7 +182,7 @@ contains ! Initial internal bubble pressure (Euler number + Laplace pressure) pb0 = Eu + 2._wp/Web/R0 - ! Vapor mass fraction at bubble wall, Ando JAS (2010) Eq. 2.19 + ! Vapor mass fraction at bubble wall, Ando JAS (2010) chi_vw0 = 1._wp/(1._wp + R_v/R_g*(pb0/pv - 1._wp)) ! Mixture specific heat from mass-weighted vapor/gas contributions @@ -206,7 +206,7 @@ contains ! Peclet numbers Pe_T(:) = rho_m0*cp_m0(:)/k_m0(:) - ! Bubble natural frequency, Ando JAS (2010) Eq. B.1 + ! Bubble natural frequency, Ando JAS (2010) omegaN(:) = sqrt(3._wp*k_poly*Ca + 2._wp*(3._wp*k_poly - 1._wp)/(Web*R0))/R0/sqrt(rho0ref) do ir = 1, nb call s_transcoeff(omegaN(ir)*R0(ir), Pe_T(ir)*R0(ir), Re_trans_T(ir), Im_trans_T(ir)) diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index d04cfc5e5b..78546946f9 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -54,9 +54,7 @@ contains !! selecting the phase change module that will be used (pT- or pTg-equilibrium) impure subroutine s_initialize_phasechange_module - ! Saturation curve coefficients derived from Clausius-Clapeyron relation via stiffened gas EOS. Saurel et al. JCP (2008), Le - ! Metayer et al. JFE (2004) gs_min = gamma-1, cvs = specific heat at constant volume, qvps = reference entropy, qvs = - ! reference energy + ! Saturation curve coefficients via stiffened gas EOS. Saurel et al. JCP (2008), Le Metayer et al. JFE (2004) A = (gs_min(lp)*cvs(lp) - gs_min(vp)*cvs(vp) + qvps(vp) - qvps(lp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) B = (qvs(lp) - qvs(vp))/((gs_min(vp) - 1.0_wp)*cvs(vp)) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index cb0f54ec08..10ac34118d 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -572,8 +572,7 @@ contains #endif end if - ! Recover primitive variables from relativistic MHD conserved variables via Newton-Raphson iteration on total - ! enthalpy W. Mignone & Bodo A&A (2006) W = total enthalpy, Ga = Lorentz factor, B2 = |B|^2, m2 = |m|^2, S = m.B + ! Relativistic MHD primitive variable recovery, Mignone & Bodo A&A (2006) if (relativity) then if (n == 0) then B(1) = Bx0 diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 04351aed0e..240f92d50e 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -4,8 +4,7 @@ #:include 'macros.fpp' -!> @brief One-way acoustic source injection following Maeda and Colonius, JCP 2017. Supports planar, focused transducer, transducer -!! array, and broadband waveforms. +!> @brief One-way acoustic source injection, Maeda and Colonius JCP (2017) module m_acoustic_src use m_derived_types !< Definitions of the derived types diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 03d7aca075..934825ace6 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -75,8 +75,7 @@ contains end function f_rddot - !> Bubble wall pressure: stiffened gas with Laplace pressure and viscous stress Ca = cavitation number, Web = Weber number, - !! Re_inv = inverse Reynolds number Rayleigh PRSLA (1917), Plesset JAM (1949), Keller-Miksis JASA (1980) + !> Bubble wall pressure: stiffened gas with Laplace pressure and viscous stress !! @param fR0 Equilibrium bubble radius !! @param fR Current bubble radius !! @param fV Current bubble velocity @@ -234,7 +233,7 @@ contains end function f_rddot_G - !> Function that computes the bubble wall pressure for Keller--Miksis bubbles + !> Keller-Miksis bubble wall pressure !! @param fR0 Equilibrium bubble radius !! @param fR Current bubble radius !! @param fV Current bubble velocity diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 3f89eb6d94..11379f1482 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -111,9 +111,7 @@ contains @:ALLOCATE(ghost_points(1:max_num_gps)) $:GPU_ENTER_DATA(copyin='[ghost_points]') - ! Ghost-cell immersed boundary method procedure: 1. Identify ghost points adjacent to IB surface 2. Apply levelset to - ! determine inside/outside 3. Compute image points (reflection across IB surface) 4. Interpolate flow variables at image - ! points Tseng & Ferziger JCP (2003), Mittal & Iaccarino ARFM (2005) + ! Ghost-cell IBM, Tseng & Ferziger JCP (2003), Mittal & Iaccarino ARFM (2005) call s_find_ghost_points(ghost_points) call s_apply_levelset(ghost_points, num_gps) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 626606feac..e694392b09 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -526,7 +526,7 @@ contains 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 longitudinal wave speed: sqrt(c^2 + (4G/3 + tau_e)/rho), Rodriguez et al. JCP (2019) + ! 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))) & @@ -2026,8 +2026,7 @@ contains ! COMPUTING THE DIRECT WAVE SPEEDS if (wave_speeds == 1) then if (elasticity) then - ! Elastic longitudinal wave speed: sqrt(c^2 + (4G/3 + tau_e)/rho), Rodriguez et al. JCP - ! (2019) + ! 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) & @@ -3101,8 +3100,7 @@ contains if (wave_speeds == 1) then if (elasticity) then - ! Elastic longitudinal wave speed: sqrt(c^2 + (4G/3 + tau_e)/rho), Rodriguez et al. JCP - ! (2019) + ! 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) & diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index 446988476b..847d62e50b 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -160,7 +160,6 @@ contains & j, l, i) end do - ! Continuum surface force capillary stress, Schmidmayer et al. JCP (2017) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsy_vf(k, j, l, 2) end if @@ -203,7 +202,6 @@ contains & k, j, i) end do - ! Continuum surface force capillary stress, Schmidmayer et al. JCP (2017) flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, & & l) + sigma*c_divs(num_dims + 1)%sf(j, k, l)*vSrc_rsz_vf(l, k, j, 3) end if From 17d142e2422768c48f4b911b32157a3a822197ec Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 02:02:03 -0400 Subject: [PATCH 17/25] Fix unterminated comment: remove /**R pattern that triggers C-style block comment in Fypp --- src/simulation/m_riemann_solvers.fpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index e694392b09..de84894686 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3545,7 +3545,7 @@ contains 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 from the 5 wave-speed regions: L, *L, **L/**R, *R, R + ! Select HLLD flux region if (0.0_wp <= s_L) then F_hlld = F_L else if (0.0_wp <= s_starL) then From b15c089ea6e4ab9f112c7256781b8124c8559062 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 02:27:04 -0400 Subject: [PATCH 18/25] Document GPU macros and constants; remove generic use-statement comments --- src/common/include/parallel_macros.fpp | 19 ++++++++++++ src/common/m_boundary_common.fpp | 4 +-- src/common/m_checker_common.fpp | 6 ++-- src/common/m_constants.fpp | 31 +++++++++---------- src/common/m_derived_types.fpp | 2 +- src/common/m_helper.fpp | 6 ++-- src/common/m_helper_basic.fpp | 2 +- src/common/m_mpi_common.fpp | 4 +-- src/common/m_phase_change.fpp | 10 +++---- src/common/m_variables_conversion.fpp | 8 ++--- src/post_process/m_checker.fpp | 6 ++-- src/post_process/m_global_parameters.fpp | 4 +-- src/post_process/m_mpi_proxy.fpp | 4 +-- src/post_process/p_main.fpp | 2 +- src/pre_process/m_assign_variables.fpp | 2 +- src/pre_process/m_check_ib_patches.fpp | 10 +++---- src/pre_process/m_check_patches.fpp | 10 +++---- src/pre_process/m_checker.fpp | 6 ++-- src/pre_process/m_grid.f90 | 2 +- src/pre_process/m_icpp_patches.fpp | 4 +-- src/pre_process/p_main.f90 | 2 +- src/simulation/m_acoustic_src.fpp | 12 ++++---- src/simulation/m_body_forces.fpp | 4 +-- src/simulation/m_bubbles.fpp | 10 +++---- src/simulation/m_bubbles_EE.fpp | 10 +++---- src/simulation/m_bubbles_EL.fpp | 12 ++++---- src/simulation/m_bubbles_EL_kernels.fpp | 2 +- src/simulation/m_cbc.fpp | 6 ++-- src/simulation/m_checker.fpp | 6 ++-- src/simulation/m_compute_levelset.fpp | 12 ++++---- src/simulation/m_data_output.fpp | 10 +++---- src/simulation/m_derived_variables.fpp | 8 ++--- src/simulation/m_fftw.fpp | 6 ++-- src/simulation/m_global_parameters.fpp | 4 +-- src/simulation/m_hyperelastic.fpp | 6 ++-- src/simulation/m_hypoelastic.fpp | 4 +-- src/simulation/m_ib_patches.fpp | 4 +-- src/simulation/m_ibm.fpp | 10 +++---- src/simulation/m_igr.fpp | 2 +- src/simulation/m_mpi_proxy.fpp | 6 ++-- src/simulation/m_muscl.fpp | 6 ++-- src/simulation/m_pressure_relaxation.fpp | 4 +-- src/simulation/m_qbmm.fpp | 10 +++---- src/simulation/m_rhs.fpp | 20 ++++++------- src/simulation/m_riemann_solvers.fpp | 14 ++++----- src/simulation/m_sim_helpers.fpp | 2 +- src/simulation/m_start_up.fpp | 38 ++++++++++++------------ src/simulation/m_surface_tension.fpp | 8 ++--- src/simulation/m_time_steppers.fpp | 16 +++++----- src/simulation/m_viscous.fpp | 6 ++-- src/simulation/m_weno.fpp | 8 ++--- src/simulation/p_main.fpp | 2 +- 52 files changed, 216 insertions(+), 196 deletions(-) diff --git a/src/common/include/parallel_macros.fpp b/src/common/include/parallel_macros.fpp index b3b65eb9c6..b1382ec49a 100644 --- a/src/common/include/parallel_macros.fpp +++ b/src/common/include/parallel_macros.fpp @@ -2,6 +2,7 @@ #:include 'omp_macros.fpp' #:include 'acc_macros.fpp' +! GPU parallel region (scalar reductions, maxval/minval) #:def GPU_PARALLEL(code, private=None, default='present', firstprivate=None, reduction=None, reductionOp=None, & & copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, & & no_create=None, present=None, deviceptr=None, attach=None, extraAccArgs=None, extraOmpArgs=None) @@ -20,6 +21,7 @@ #endif #:enddef +! GPU parallel loop over threads (most common GPU macro) #:def GPU_PARALLEL_LOOP(collapse=None, private=None, parallelism='[gang, vector]', & & default='present', firstprivate=None, reduction=None, reductionOp=None, & & copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, & @@ -39,6 +41,7 @@ #endif #:enddef +! Required closing for GPU_PARALLEL_LOOP #:def END_GPU_PARALLEL_LOOP() #:set acc_end_directive = '!$acc end parallel loop' #:set omp_end_directive = END_OMP_PARALLEL_LOOP() @@ -50,6 +53,7 @@ #endif #:enddef +! Mark routine for device compilation #:def GPU_ROUTINE(function_name=None, parallelism=None, nohost=False, cray_inline=False, cray_noinline=False, extraAccArgs=None, & & extraOmpArgs=None) #:assert isinstance(cray_inline, bool) @@ -106,6 +110,7 @@ #:endif #:enddef +! Declare device-resident data #:def GPU_DECLARE(copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, present=None, deviceptr=None, & & link=None, extraAccArgs=None, extraOmpArgs=None) #:set acc_code = ACC_DECLARE(copy=copy, copyin=copyin, copyinReadOnly=copyinReadOnly, copyout=copyout, create=create, & @@ -123,6 +128,7 @@ #endif #:enddef +! Inner loop within a GPU parallel region #:def GPU_LOOP(collapse=None, parallelism=None, data_dependency=None, reduction=None, reductionOp=None, private=None, & & extraAccArgs=None, extraOmpArgs=None) #:set acc_code = ACC_LOOP(collapse=collapse, parallelism=parallelism, data_dependency=data_dependency, reduction=reduction, & @@ -137,6 +143,7 @@ #endif #:enddef +! Scoped GPU data region #:def GPU_DATA(code, copy=None, copyin=None, copyinReadOnly=None, copyout=None, create=None, no_create=None, present=None, & & deviceptr=None, attach=None, default=None, extraAccArgs=None, extraOmpArgs=None) #:set acc_code = ACC_DATA(code=code, copy=copy, copyin=copyin, copyinReadOnly=copyinReadOnly, copyout=copyout, create=create, & @@ -155,6 +162,7 @@ #endif #:enddef +! Host code with device pointers (for MPI with GPU buffers) #:def GPU_HOST_DATA(code, use_device_addr=None, use_device_ptr=None, extraAccArgs=None, extraOmpArgs=None) #:if use_device_addr is not None and use_device_ptr is not None #:set use_device_addr_end_index = len(use_device_addr) - 1 @@ -183,6 +191,7 @@ #endif #:enddef +! Allocate device memory (unscoped) #:def GPU_ENTER_DATA(copyin=None, copyinReadOnly=None, create=None, attach=None, extraAccArgs=None, extraOmpArgs=None) #:set acc_code = ACC_ENTER_DATA(copyin=copyin, copyinReadOnly=copyinReadOnly, create=create, attach=attach, & & extraAccArgs=extraAccArgs) @@ -196,6 +205,7 @@ #endif #:enddef +! Free device memory #:def GPU_EXIT_DATA(copyout=None, delete=None, detach=None, extraAccArgs=None, extraOmpArgs=None) #:set acc_code = ACC_EXIT_DATA(copyout=copyout, delete=delete, detach=detach, extraAccArgs=extraAccArgs) #:set omp_code = OMP_EXIT_DATA(copyout=copyout, delete=delete, detach=detach, extraOmpArgs=extraOmpArgs) @@ -207,6 +217,7 @@ #endif #:enddef +! Atomic operation on device #:def GPU_ATOMIC(atomic, extraAccArgs=None, extraOmpArgs=None) #:set acc_code = ACC_ATOMIC(atomic=atomic, extraAccArgs=extraAccArgs) #:set omp_code = OMP_ATOMIC(atomic=atomic, extraOmpArgs=extraOmpArgs) @@ -218,6 +229,7 @@ #endif #:enddef +! End atomic capture block #:def END_GPU_ATOMIC_CAPTURE() #:set acc_end_directive = '!$acc end atomic' #:set omp_end_directive = '!$omp end atomic' @@ -228,6 +240,7 @@ #endif #:enddef +! Copy data between host and device #:def GPU_UPDATE(host=None, device=None, extraAccArgs=None, extraOmpArgs=None) #:set acc_code = ACC_UPDATE(host=host, device=device, extraAccArgs=extraAccArgs) #:set omp_code = OMP_UPDATE(host=host, device=device, extraOmpArgs=extraOmpArgs) @@ -239,6 +252,7 @@ #endif #:enddef +! Synchronization barrier #:def GPU_WAIT(extraAccArgs=None, extraOmpArgs=None) #:set acc_code = ACC_WAIT(extraAccArgs=extraAccArgs) #:set omp_code = OMP_WAIT(extraOmpArgs=extraOmpArgs) @@ -250,6 +264,7 @@ #endif #:enddef +! Import GPU library module (openacc or omp_lib) #:def USE_GPU_MODULE() #if defined(MFC_OpenACC) use openacc @@ -258,24 +273,28 @@ #endif #:enddef +! Emit code only for AMD compiler #:def DEF_AMD(code) #:if MFC_COMPILER == AMD_COMPILER_ID $:code #:endif #:enddef +! Emit code for non-Cray compilers #:def UNDEF_CCE(code) #:if MFC_COMPILER != CCE_COMPILER_ID $:code #:endif #:enddef +! Emit code only for Cray compiler #:def DEF_CCE(code) #:if MFC_COMPILER == CCE_COMPILER_ID $:code #:endif #:enddef +! Emit code for non-NVIDIA compilers #:def UNDEF_NVIDIA(code) #:if MFC_COMPILER != NVIDIA_COMPILER_ID and MFC_COMPILER != PGI_COMPILER_ID $:code diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index b95c02ce5b..d0df6786ef 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -8,8 +8,8 @@ module m_boundary_common - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types + use m_global_parameters use m_mpi_proxy use m_constants use m_delay_file_access diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index f159ba81e3..ec03cd9c7f 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -8,9 +8,9 @@ !> @brief Shared input validation checks for grid dimensions and AMD GPU compiler limits module m_checker_common - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_global_parameters + use m_mpi_proxy + use m_helper_basic use m_helper implicit none diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index 790d97ea1d..a9dc7bbd6e 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -23,11 +23,11 @@ module m_constants integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation - integer, parameter :: num_patches_max = 1000 - integer, parameter :: num_bc_patches_max = 10 + integer, parameter :: num_patches_max = 1000 !< Maximum number of IC patches + integer, parameter :: num_bc_patches_max = 10 !< Maximum number of boundary condition patches integer, parameter :: max_2d_fourier_modes = 10 !< Max Fourier mode index for 2D modal patch (geometry 13) integer, parameter :: max_sph_harm_degree = 5 !< Max degree L for 3D spherical harmonic patch (geometry 14) - integer, parameter :: pathlen_max = 400 + integer, parameter :: pathlen_max = 400 !< Maximum path length for STL/OBJ model files integer, parameter :: nnode = 4 !< Number of QBMM nodes integer, parameter :: dflt_num_igr_iters = 2 !< number of iterations for IGR elliptic solve integer, parameter :: dflt_num_igr_warm_start_iters = 50 !< default number of iterations for IGR elliptic solve @@ -68,24 +68,25 @@ module m_constants integer, parameter :: dflt_adap_dt_max_iters = 100 !< Default max iteration for adaptive step size ! Constants of the algorithm described by Heirer, E. Hairer, S. P.Norsett, G. Wanner, Solving Ordinary Differential Equations I, ! Chapter II.4 to choose the initial time step size for the adaptive time stepping routine - real(wp), parameter :: threshold_first_guess = 1.e-5_wp - real(wp), parameter :: threshold_second_guess = 1.e-15_wp - real(wp), parameter :: scale_first_guess = 1.e-3_wp - real(wp), parameter :: scale_guess = 1.e-2_wp - real(wp), parameter :: small_guess = 1.e-6_wp + real(wp), parameter :: threshold_first_guess = 1.e-5_wp !< Threshold for initial step size estimate + real(wp), parameter :: threshold_second_guess = 1.e-15_wp !< Threshold for refined step size estimate + real(wp), parameter :: scale_first_guess = 1.e-3_wp !< Scale factor for initial step size + real(wp), parameter :: scale_guess = 1.e-2_wp !< Scale factor for step size adjustment + real(wp), parameter :: small_guess = 1.e-6_wp !< Minimum initial step size ! Relativity + !> Max Newton-Raphson iterations for relativistic primitive recovery integer, parameter :: relativity_cons_to_prim_max_iter = 100 - ! Pseudo-random number generator - integer, parameter :: modulus = 2**30 - 1 - integer, parameter :: multiplier = 1664525 - integer, parameter :: increment = 1013904223 - integer, parameter :: amplifier = 3**13 - real(wp), parameter :: decimal_trim = 1.e5_wp + ! Linear congruential pseudo-random number generator parameters + integer, parameter :: modulus = 2**30 - 1 !< PRNG modulus + integer, parameter :: multiplier = 1664525 !< PRNG multiplier + integer, parameter :: increment = 1013904223 !< PRNG increment + integer, parameter :: amplifier = 3**13 !< PRNG amplifier for mixing + real(wp), parameter :: decimal_trim = 1.e5_wp !< PRNG decimal truncation factor ! System constants - integer, parameter :: CASE_FILE_ERROR_CODE = 22 + integer, parameter :: CASE_FILE_ERROR_CODE = 22 !< Exit code for case file validation errors ! Boundary condition enumeration Abbreviations CHAR - Characteristic NR - Non-reflecting SUB - subsonic SUP - supersonic FF - ! Force-free CP - Constant pressure diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index d9ff1782ee..0ed66761c2 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -7,7 +7,7 @@ !> @brief Shared derived types for field data, patch geometry, bubble dynamics, and MPI I/O structures module m_derived_types - use m_constants !< Constants + use m_constants use m_precision_select use m_thermochem, only: num_species diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index 976cd6ed15..1ebf8537a2 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -8,9 +8,9 @@ !> @brief Utility routines for bubble model setup, coordinate transforms, array sampling, and special functions module m_helper - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use ieee_arithmetic !< For checking NaN + use m_derived_types + use m_global_parameters + use ieee_arithmetic !< For checking NaN implicit none private; diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 47ec5073e7..deff316401 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -7,7 +7,7 @@ !> @brief Basic floating-point utilities: approximate equality, default detection, and coordinate bounds module m_helper_basic - use m_derived_types !< Definitions of the derived types + use m_derived_types implicit none private; diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 7ad96ee897..4dea1b31b7 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -12,8 +12,8 @@ module m_mpi_common use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types + use m_global_parameters use m_helper use ieee_arithmetic use m_nvtx diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index 78546946f9..c2ce84c865 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -9,12 +9,12 @@ module m_phase_change #ifndef MFC_POST_PROCESS - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_variables_conversion use ieee_arithmetic - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic implicit none private; diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 10ac34118d..3943977633 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -8,10 +8,10 @@ !> @brief Conservative-to-primitive variable conversion, mixture property evaluation, and pressure computation module m_variables_conversion - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_helper_basic use m_helper use m_thermochem, only: num_species, get_temperature, get_pressure, gas_constant, get_mixture_molecular_weight, & & get_mixture_energy_mass diff --git a/src/post_process/m_checker.fpp b/src/post_process/m_checker.fpp index 035281b88b..c46bc8fd0b 100644 --- a/src/post_process/m_checker.fpp +++ b/src/post_process/m_checker.fpp @@ -7,9 +7,9 @@ !> @brief Validates post-process input parameters and output format consistency module m_checker - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_global_parameters + use m_mpi_proxy + use m_helper_basic use m_helper implicit none diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index c15152c75a..2672cc214b 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -11,8 +11,8 @@ module m_global_parameters use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types + use m_helper_basic use m_thermochem, only: num_species, species_names implicit none diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index 947114793a..77d20fe562 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -9,8 +9,8 @@ module m_mpi_proxy use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code + use m_derived_types + use m_global_parameters use m_mpi_common use ieee_arithmetic diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index 2f3c710859..980a8b8627 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -8,7 +8,7 @@ !! fraction, specific heat ratio, liquid stiffness, speed of sound, vorticity and the numerical Schlieren function. program p_main - use m_global_parameters !< Global parameters for the code + use m_global_parameters use m_start_up implicit none diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index 79f4b3825c..060b00c859 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -11,7 +11,7 @@ module m_assign_variables use m_derived_types use m_global_parameters use m_variables_conversion - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_thermochem, only: num_species, gas_constant, get_mixture_molecular_weight implicit none diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index cbeadc71a3..afbcd7baf5 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -8,16 +8,16 @@ module m_check_ib_patches - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Procedures to write the grid data and the conservative variables to files + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_data_output #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif use m_compile_specific - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_helper implicit none diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 4287e31d17..3e3480b0ee 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -11,16 +11,16 @@ module m_check_patches ! Dependencies - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Procedures to write the grid data and the conservative variables to files + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_data_output #ifdef MFC_MPI use mpi !< Message passing interface (MPI) module #endif use m_compile_specific - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_helper implicit none diff --git a/src/pre_process/m_checker.fpp b/src/pre_process/m_checker.fpp index bfd47ff473..bd6ca48ee0 100644 --- a/src/pre_process/m_checker.fpp +++ b/src/pre_process/m_checker.fpp @@ -7,9 +7,9 @@ !> @brief Checks pre-process input file parameters for compatibility and correctness module m_checker - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_global_parameters + use m_mpi_proxy + use m_helper_basic use m_helper implicit none diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index 49f45f5faf..40542d3041 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -8,7 +8,7 @@ module m_grid use m_derived_types ! Definitions of the derived types use m_global_parameters ! Global parameters for the code use m_mpi_proxy ! Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic #ifdef MFC_MPI use mpi ! Message passing interface (MPI) module #endif diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 1aa96e7947..8f41d36a47 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -14,9 +14,9 @@ module m_icpp_patches use m_model ! Subroutine(s) related to STL files use m_derived_types ! Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_global_parameters use m_constants, only: max_2d_fourier_modes, max_sph_harm_degree, small_radius - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_helper use m_mpi_common use m_assign_variables diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index 43e5b083c0..c61b120f09 100644 --- a/src/pre_process/p_main.f90 +++ b/src/pre_process/p_main.f90 @@ -5,7 +5,7 @@ !> @brief This program takes care of setting up the initial condition and grid data for the multicomponent flow code. program p_main - use m_global_parameters !< Global parameters for the code + use m_global_parameters use m_start_up implicit none diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 240f92d50e..bfa4488473 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -7,12 +7,12 @@ !> @brief One-way acoustic source injection, Maeda and Colonius JCP (2017) module m_acoustic_src - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_bubbles !< Bubble dynamic routines - use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers - use m_constants !< Definitions of the constants + use m_derived_types + use m_global_parameters + use m_bubbles + use m_variables_conversion + use m_helper_basic + use m_constants implicit none private; public :: s_initialize_acoustic_src, s_precalculate_acoustic_spatial_sources, s_acoustic_src_calculations diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index fb9ffdaaf0..d0bd16a9b1 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -7,8 +7,8 @@ !> @brief Computes gravitational and user-defined body force source terms for the momentum equations module m_body_forces - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types + use m_global_parameters use m_variables_conversion use m_nvtx diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 934825ace6..201f1b180b 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -8,11 +8,11 @@ !! models module m_bubbles - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_variables_conversion + use m_helper_basic implicit none real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index 03c34e2b10..eef4d01d5c 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -7,11 +7,11 @@ !> @brief Computes ensemble-averaged (Euler--Euler) bubble source terms for radius, velocity, pressure, and mass transfer module m_bubbles_EE - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_bubbles !< General bubble dynamics procedures + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_variables_conversion + use m_bubbles implicit none real(wp), allocatable, dimension(:,:,:) :: bub_adv_src diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index dcce585649..fa06d43877 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -7,14 +7,14 @@ !> @brief Tracks Lagrangian bubbles and couples their dynamics to the Eulerian flow via volume averaging module m_bubbles_EL - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_bubbles_EL_kernels !< Definitions of the kernel functions - use m_bubbles !< General bubble dynamics procedures - use m_variables_conversion !< State variables type conversion procedures + use m_global_parameters + use m_mpi_proxy + use m_bubbles_EL_kernels + use m_bubbles + use m_variables_conversion use m_compile_specific use m_boundary_common - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_sim_helpers use m_helper diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index 2e05234a62..257f00d1ac 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -7,7 +7,7 @@ !> @brief Kernel functions (Gaussian, delta) that smear Lagrangian bubble effects onto the Eulerian grid module m_bubbles_EL_kernels - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy implicit none contains diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 41b34074e4..ba0792cd1c 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -8,9 +8,9 @@ module m_cbc - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion !< State variables type conversion procedures + use m_derived_types + use m_global_parameters + use m_variables_conversion use m_compute_cbc use m_thermochem, only: get_mixture_energy_mass, get_mixture_specific_heat_cv_mass, get_mixture_specific_heat_cp_mass, & & gas_constant, get_mixture_molecular_weight, get_species_enthalpies_rt, molecular_weights, get_species_specific_heats_r, & diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 2972aeea4e..4a24103714 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -8,10 +8,10 @@ !> @brief Validates simulation input parameters for consistency and supported configurations module m_checker - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_global_parameters + use m_mpi_proxy use m_helper - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic implicit none private; public :: s_check_inputs diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index 08dbade6e2..abac4af1a9 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -7,12 +7,12 @@ !> @brief Computes signed-distance level-set fields and surface normals for immersed-boundary patch geometries module m_compute_levelset - use m_ib_patches !< The IB patch parameters - use m_model !< Subroutine(s) related to STL files - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_helper_basic !< Functions to compare floating point numbers + use m_ib_patches + use m_model + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_helper_basic implicit none private; public :: s_apply_levelset diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 4b4030c898..c1bf848ef9 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -8,13 +8,13 @@ !> @brief Writes solution data, run-time stability diagnostics (ICFL, VCFL, CCFL, Rc), and probe/center-of-mass files module m_data_output - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_variables_conversion use m_compile_specific use m_helper - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_sim_helpers use m_delay_file_access use m_ibm diff --git a/src/simulation/m_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index de1703c921..d7f3701878 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -8,10 +8,10 @@ module m_derived_variables - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Global parameters for the code - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_data_output !< Data output module + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_data_output use m_compile_specific use m_helper use m_finite_differences diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 339fedd220..395cff99cb 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -9,9 +9,9 @@ module m_fftw use, intrinsic :: iso_c_binding - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types + use m_global_parameters + use m_mpi_proxy #if defined(MFC_GPU) && defined(__PGI) use cufft #elif defined(MFC_GPU) diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 8ac272843a..8ed4845d29 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -12,8 +12,8 @@ module m_global_parameters use mpi !< Message passing interface (MPI) module #endif - use m_derived_types !< Definitions of the derived types - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types + use m_helper_basic ! $:USE_GPU_MODULE() implicit none diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index 35edc1d0e1..8cef3e6784 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -8,9 +8,9 @@ module m_hyperelastic - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion !< State variables type conversion procedures + use m_derived_types + use m_global_parameters + use m_variables_conversion use m_finite_differences implicit none diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index b3b6c907c5..0b929bd61e 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -7,8 +7,8 @@ !> @brief Computes hypoelastic stress-rate source terms and damage-state evolution module m_hypoelastic - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types + use m_global_parameters use m_finite_differences use m_helper diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index 3c5ade657f..c7f2fa8086 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -14,8 +14,8 @@ module m_ib_patches use m_model ! Subroutine(s) related to STL files use m_derived_types ! Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_helper_basic !< Functions to compare floating point numbers + use m_global_parameters + use m_helper_basic use m_helper use m_mpi_common diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 11379f1482..e383a64487 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -8,12 +8,12 @@ !! flow state module m_ibm - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_variables_conversion use m_helper - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_constants use m_compute_levelset use m_ib_patches diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index cb76b4359d..64be97fafc 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -8,7 +8,7 @@ !> @brief Iterative ghost rasterization (IGR) for sharp immersed boundary treatment module m_igr - use m_derived_types !< Definitions of the derived types + use m_derived_types use m_global_parameters use m_variables_conversion use m_mpi_proxy diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index a3c72caae8..aec11b1d37 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -12,10 +12,10 @@ module m_mpi_proxy use mpi !< Message passing interface (MPI) module #endif - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_helper - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types + use m_global_parameters use m_mpi_common use m_nvtx use ieee_arithmetic diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index 61e48f038d..eb008a248d 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -7,9 +7,9 @@ !> @brief MUSCL reconstruction with interface sharpening for contact-preserving advection module m_muscl - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion !< State variables type conversion procedures + use m_derived_types + use m_global_parameters + use m_variables_conversion #ifdef MFC_OpenACC use openacc #endif diff --git a/src/simulation/m_pressure_relaxation.fpp b/src/simulation/m_pressure_relaxation.fpp index eae3e1c10d..26f02c411a 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -9,8 +9,8 @@ !! correction module m_pressure_relaxation - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types + use m_global_parameters implicit none private; public :: s_pressure_relaxation_procedure, s_initialize_pressure_relaxation_module, & diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index eac335a29d..04e0793fa4 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -8,11 +8,11 @@ !> @brief Quadrature-based moment methods (QBMM) for polydisperse bubble moment inversion and transport module m_qbmm - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_helper_basic !< Functions to compare floating point numbers + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_variables_conversion + use m_helper_basic use m_helper implicit none diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index f77e83bfdf..7ebbd43bb9 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -9,17 +9,17 @@ !! physical source terms module m_rhs - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_weno !< Weighted and essentially non-oscillatory (WENO) schemes for spatial reconstruction of variables - use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws - use m_riemann_solvers !< Exact and approximate Riemann problem solvers - use m_cbc !< Characteristic boundary conditions (CBC) - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_variables_conversion + use m_weno + use m_muscl + use m_riemann_solvers + use m_cbc + use m_bubbles_EE use m_bubbles_EL - use m_qbmm !< Moment inversion + use m_qbmm use m_hypoelastic use m_hyperelastic use m_acoustic_src diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index de84894686..aa0ac5adc5 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -10,14 +10,14 @@ module m_riemann_solvers - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy - use m_variables_conversion !< State variables type conversion procedures - use m_bubbles !< To get the bubble wall pressure function + use m_derived_types + use m_global_parameters + use m_mpi_proxy + use m_variables_conversion + use m_bubbles use m_bubbles_EE - use m_surface_tension !< To get the capillary fluxes - use m_helper_basic !< Functions to compare floating point numbers + use m_surface_tension + use m_helper_basic 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 diff --git a/src/simulation/m_sim_helpers.fpp b/src/simulation/m_sim_helpers.fpp index 897bf8ea90..2688e42b1c 100644 --- a/src/simulation/m_sim_helpers.fpp +++ b/src/simulation/m_sim_helpers.fpp @@ -8,7 +8,7 @@ !> @brief Simulation helper routines for enthalpy computation, CFL calculation, and stability checks module m_sim_helpers - use m_derived_types !< Definitions of the derived types + use m_derived_types use m_global_parameters use m_variables_conversion diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index e061139419..65d79ac804 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -8,31 +8,31 @@ !> @brief Reads input files, loads initial conditions and grid data, and orchestrates solver initialization and finalization module m_start_up - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types + use m_global_parameters + use m_mpi_proxy use m_mpi_common - use m_variables_conversion !< State variables type conversion procedures - use m_weno !< Weighted and essentially non-oscillatory (WENO) schemes for spatial reconstruction of variables - use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for convservation laws - use m_riemann_solvers !< Exact and approximate Riemann problem solvers - use m_cbc !< Characteristic boundary conditions (CBC) + use m_variables_conversion + use m_weno + use m_muscl + use m_riemann_solvers + use m_cbc use m_boundary_common - use m_acoustic_src !< Acoustic source calculations - use m_rhs !< Right-hand-side (RHS) evaluation procedures - use m_chemistry !< Chemistry module - use m_data_output !< Run-time info & solution data output procedures - use m_time_steppers !< Time-stepping algorithms - use m_qbmm !< Quadrature MOM - use m_derived_variables !< Procedures used to compute quantities derived from the conservative and primitive variables + use m_acoustic_src + use m_rhs + use m_chemistry + use m_data_output + use m_time_steppers + use m_qbmm + use m_derived_variables use m_hypoelastic use m_hyperelastic - use m_phase_change !< Phase-change module + use m_phase_change use m_viscous - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL !< Lagrange bubble dynamics routines + use m_bubbles_EE + use m_bubbles_EL use ieee_arithmetic - use m_helper_basic !< Functions to compare floating point numbers + use m_helper_basic use m_helper $:USE_GPU_MODULE() diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index 847d62e50b..b32368db0c 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -9,12 +9,12 @@ !> @brief Computes capillary source fluxes and color-function gradients for the diffuse-interface surface tension model module m_surface_tension - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_derived_types + use m_global_parameters + use m_mpi_proxy use m_variables_conversion use m_weno - use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws + use m_muscl use m_helper use m_boundary_common diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 13d5609581..80e3240e58 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -8,16 +8,16 @@ !> @brief Total-variation-diminishing (TVD) Runge--Kutta time integrators (1st-, 2nd-, and 3rd-order SSP) module m_time_steppers - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_rhs !< Right-hane-side (RHS) evaluation procedures - use m_pressure_relaxation !< Pressure relaxation procedures - use m_data_output !< Run-time info & solution data output procedures - use m_bubbles_EE !< Ensemble-averaged bubble dynamics routines - use m_bubbles_EL !< Lagrange bubble dynamics routines + use m_derived_types + use m_global_parameters + use m_rhs + use m_pressure_relaxation + use m_data_output + use m_bubbles_EE + use m_bubbles_EL use m_ibm use m_hyperelastic - use m_mpi_proxy !< Message passing interface (MPI) module proxy + use m_mpi_proxy use m_boundary_common use m_helper use m_sim_helpers diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 952c7aa7e6..6ebbec844b 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -7,10 +7,10 @@ !> @brief Computes viscous stress tensors and diffusive flux contributions for the Navier--Stokes equations module m_viscous - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters + use m_derived_types + use m_global_parameters use m_weno - use m_muscl !< Monotonic Upstream-centered (MUSCL) schemes for conservation laws + use m_muscl use m_helper use m_finite_differences diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index b85e750307..a61d49f0f8 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -7,13 +7,13 @@ !> @brief WENO/WENO-Z/TENO reconstruction with optional monotonicity-preserving bounds and mapped weights module m_weno - use m_derived_types !< Definitions of the derived types - use m_global_parameters !< Definitions of the global parameters - use m_variables_conversion !< State variables type conversion procedures + use m_derived_types + use m_global_parameters + use m_variables_conversion ! $:USE_GPU_MODULE() use m_mpi_proxy - use m_muscl !< For Interface Compression + use m_muscl private; public :: s_initialize_weno_module, s_initialize_weno, s_finalize_weno_module, s_weno !> @name The cell-average variables that will be WENO-reconstructed. Formerly, they are stored in v_vf. However, they are diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index 46528ebd3f..86f7e82eba 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -10,7 +10,7 @@ !! fraction model. program p_main - use m_global_parameters !< Definitions of the global parameters + use m_global_parameters use m_start_up use m_time_steppers use m_nvtx From eb81d5ce7ad87f550c870e7f88a5914aef87f5a3 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 02:31:23 -0400 Subject: [PATCH 19/25] Fix dead Stanford link in NACA airfoil docs --- docs/documentation/case.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/documentation/case.md b/docs/documentation/case.md index 756538c2f2..ecdeb786d4 100644 --- a/docs/documentation/case.md +++ b/docs/documentation/case.md @@ -349,7 +349,7 @@ Definitions for currently implemented immersed boundary patch types are listed i - `c`, `t`, `p`, and `m` specify the parameters for a NACA airfoil. `m` is the maximum camber, `p` is the location of maximum camber, `c` is the coord length, and `t` is the thickness. -Additional details on this specification can be found in [The Naca Airfoil Series](https://web.stanford.edu/~cantwell/AA200_Course_Material/The%20NACA%20airfoil%20series.pdf) +Additional details on this specification can be found in [NACA airfoil](https://en.wikipedia.org/wiki/NACA_airfoil). - `slip` applies a slip boundary to the surface of the patch if true and a no-slip boundary condition to the surface if false. From 81e4e988fbb87e7cea816263718d8354d90316b5 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 16:34:25 -0400 Subject: [PATCH 20/25] Fix comment typos, remove dead code, apply ffmt S102/S081 formatting --- src/common/include/1dHardcodedIC.fpp | 2 +- src/common/include/2dHardcodedIC.fpp | 44 ++- src/common/include/3dHardcodedIC.fpp | 32 +- src/common/include/ExtrusionHardcodedIC.fpp | 16 +- src/common/m_boundary_common.fpp | 182 +++++----- src/common/m_checker_common.fpp | 2 +- src/common/m_compile_specific.f90 | 4 +- src/common/m_constants.fpp | 104 +++--- src/common/m_derived_types.fpp | 272 +++++++-------- src/common/m_finite_differences.fpp | 6 +- src/common/m_helper.fpp | 16 +- src/common/m_helper_basic.fpp | 2 +- src/common/m_model.fpp | 44 +-- src/common/m_mpi_common.fpp | 100 +++--- src/common/m_nvtx.f90 | 12 +- src/common/m_phase_change.fpp | 40 +-- src/common/m_precision_select.f90 | 8 +- src/common/m_variables_conversion.fpp | 88 ++--- src/post_process/m_data_input.f90 | 10 +- src/post_process/m_data_output.fpp | 8 +- src/post_process/m_derived_variables.fpp | 42 +-- src/post_process/m_global_parameters.fpp | 172 +++++----- src/post_process/m_mpi_proxy.fpp | 18 +- src/post_process/m_start_up.fpp | 11 +- src/post_process/p_main.fpp | 2 +- src/pre_process/m_assign_variables.fpp | 22 +- src/pre_process/m_check_ib_patches.fpp | 4 +- src/pre_process/m_check_patches.fpp | 2 +- src/pre_process/m_data_output.fpp | 20 +- src/pre_process/m_global_parameters.fpp | 212 ++++++------ src/pre_process/m_grid.f90 | 22 +- src/pre_process/m_icpp_patches.fpp | 44 +-- src/pre_process/m_initial_condition.fpp | 12 +- src/pre_process/m_start_up.fpp | 4 +- src/simulation/m_acoustic_src.fpp | 104 +++--- src/simulation/m_body_forces.fpp | 12 +- src/simulation/m_bubbles.fpp | 28 +- src/simulation/m_bubbles_EE.fpp | 18 +- src/simulation/m_bubbles_EL.fpp | 84 ++--- src/simulation/m_bubbles_EL_kernels.fpp | 4 +- src/simulation/m_cbc.fpp | 50 +-- src/simulation/m_checker.fpp | 4 +- src/simulation/m_compute_levelset.fpp | 76 ++--- src/simulation/m_data_output.fpp | 128 +++---- src/simulation/m_derived_variables.fpp | 40 +-- src/simulation/m_fftw.fpp | 16 +- src/simulation/m_global_parameters.fpp | 352 ++++++++++---------- src/simulation/m_hyperelastic.fpp | 12 +- src/simulation/m_hypoelastic.fpp | 22 +- src/simulation/m_ib_patches.fpp | 96 +++--- src/simulation/m_ibm.fpp | 101 +++--- src/simulation/m_igr.fpp | 18 +- src/simulation/m_mpi_proxy.fpp | 8 +- src/simulation/m_muscl.fpp | 16 +- src/simulation/m_qbmm.fpp | 6 +- src/simulation/m_rhs.fpp | 123 ++++--- src/simulation/m_riemann_solvers.fpp | 178 +++++----- src/simulation/m_start_up.fpp | 21 +- src/simulation/m_surface_tension.fpp | 2 +- src/simulation/m_time_steppers.fpp | 60 ++-- src/simulation/m_viscous.fpp | 30 +- src/simulation/m_weno.fpp | 59 ++-- src/simulation/p_main.fpp | 6 +- 63 files changed, 1621 insertions(+), 1632 deletions(-) diff --git a/src/common/include/1dHardcodedIC.fpp b/src/common/include/1dHardcodedIC.fpp index 7b100bced5..80b7e9edcb 100644 --- a/src/common/include/1dHardcodedIC.fpp +++ b/src/common/include/1dHardcodedIC.fpp @@ -5,7 +5,7 @@ #:def Hardcoded1D() select case (patch_icpp(patch_id)%hcid) - case (150) ! 1D Smooth Alfven Case for MHD + case (150) ! 1D Smooth Alfven Case for MHD ! velocity q_prim_vf(momxb + 1)%sf(i, 0, 0) = 0.1_wp*sin(2._wp*pi*x_cc(i)) q_prim_vf(momxb + 2)%sf(i, 0, 0) = 0.1_wp*cos(2._wp*pi*x_cc(i)) diff --git a/src/common/include/2dHardcodedIC.fpp b/src/common/include/2dHardcodedIC.fpp index c7aca27a98..abbe4b172e 100644 --- a/src/common/include/2dHardcodedIC.fpp +++ b/src/common/include/2dHardcodedIC.fpp @@ -17,19 +17,17 @@ #:enddef #:def Hardcoded2D() - select case (patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case + select case (patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case case (200) if (y_cc(j) <= (-x_cc(i)**3 + 1)**(1._wp/3._wp)) then ! Volume Fractions q_prim_vf(advxb)%sf(i, j, 0) = eps q_prim_vf(advxe)%sf(i, j, 0) = 1._wp - eps - ! Densities q_prim_vf(contxb)%sf(i, j, 0) = eps*1000._wp q_prim_vf(contxe)%sf(i, j, 0) = (1._wp - eps)*1._wp - ! Pressure q_prim_vf(E_idx)%sf(i, j, 0) = 1000._wp end if - case (202) ! Gresho vortex (Gouasmi et al 2022 JCP) + case (202) ! Gresho vortex (Gouasmi et al 2022 JCP) r = ((x_cc(i) - 0.5_wp)**2 + (y_cc(j) - 0.5_wp)**2)**0.5_wp rmax = 0.2_wp @@ -50,7 +48,7 @@ q_prim_vf(momxe)%sf(i, j, 0) = 0._wp q_prim_vf(E_idx)%sf(i, j, 0) = p0 + umax**2*(-2 + 4*log(2._wp)) end if - case (203) ! Gresho vortex (Gouasmi et al 2022 JCP) with density correction + case (203) ! Gresho vortex (Gouasmi et al 2022 JCP) with density correction r = ((x_cc(i) - 0.5_wp)**2._wp + (y_cc(j) - 0.5_wp)**2)**0.5_wp rmax = 0.2_wp @@ -73,7 +71,7 @@ end if q_prim_vf(contxb)%sf(i, j, 0) = q_prim_vf(E_idx)%sf(i, j, 0)**(1._wp/gam) - case (204) ! Rayleigh-Taylor instability + case (204) ! Rayleigh-Taylor instability rhoH = 3._wp rhoL = 1._wp pRef = 1.e5_wp @@ -104,10 +102,10 @@ pInt = pref + rhoH*9.81_wp*(1.2_wp - intH) q_prim_vf(E_idx)%sf(i, j, 0) = pInt + rhoL*9.81_wp*(intH - y_cc(j)) end if - case (205) ! 2D lung wave interaction problem - h = 0.0_wp ! non dim origin y - lam = 1.0_wp ! non dim lambda - amp = patch_icpp(patch_id)%a(2) ! to be changed later! !non dim amplitude + case (205) ! 2D lung wave interaction problem + h = 0.0_wp ! non dim origin y + lam = 1.0_wp ! non dim lambda + amp = patch_icpp(patch_id)%a(2) ! to be changed later! !non dim amplitude intH = amp*sin(2*pi*x_cc(i)/lam - pi/2) + h @@ -118,26 +116,26 @@ q_prim_vf(advxb)%sf(i, j, 0) = patch_icpp(1)%alpha(1) q_prim_vf(advxe)%sf(i, j, 0) = patch_icpp(1)%alpha(2) end if - case (206) ! 2D lung wave interaction problem - horizontal domain - h = 0.0_wp ! non dim origin y - lam = 1.0_wp ! non dim lambda + case (206) ! 2D lung wave interaction problem - horizontal domain + h = 0.0_wp ! non dim origin y + lam = 1.0_wp ! non dim lambda amp = patch_icpp(patch_id)%a(2) intL = amp*sin(2*pi*y_cc(j)/lam - pi/2) + h - if (x_cc(i) > intL) then ! this is the liquid + if (x_cc(i) > intL) then ! this is the liquid q_prim_vf(contxb)%sf(i, j, 0) = patch_icpp(1)%alpha_rho(1) q_prim_vf(contxe)%sf(i, j, 0) = patch_icpp(1)%alpha_rho(2) q_prim_vf(E_idx)%sf(i, j, 0) = patch_icpp(1)%pres q_prim_vf(advxb)%sf(i, j, 0) = patch_icpp(1)%alpha(1) q_prim_vf(advxe)%sf(i, j, 0) = patch_icpp(1)%alpha(2) end if - case (207) ! Kelvin Helmholtz Instability + case (207) ! Kelvin Helmholtz Instability sigma = 0.05_wp/sqrt(2.0_wp) gauss1 = exp(-(y_cc(j) - 0.75_wp)**2/(2.0_wp*sigma**2)) gauss2 = exp(-(y_cc(j) - 0.25_wp)**2/(2.0_wp*sigma**2)) q_prim_vf(momxb + 1)%sf(i, j, 0) = 0.1_wp*sin(4.0_wp*pi*x_cc(i))*(gauss1 + gauss2) - case (208) ! Richtmeyer Meshkov Instability + case (208) ! Richtmeyer Meshkov Instability lam = 1.0_wp eps = 1.0e-6_wp ei = 5.0_wp @@ -152,7 +150,7 @@ q_prim_vf(advxb)%sf(i, j, 0) = alpha_sf6 q_prim_vf(advxe)%sf(i, j, 0) = alpha_air end if - case (250) ! MHD Orszag-Tang vortex + case (250) ! MHD Orszag-Tang vortex ! gamma = 5/3 rho = 25/(36*pi) p = 5/(12*pi) v = (-sin(2*pi*y), sin(2*pi*x), 0) B = (-sin(2*pi*y)/sqrt(4*pi), ! sin(4*pi*x)/sqrt(4*pi), 0) @@ -161,7 +159,7 @@ q_prim_vf(B_idx%beg)%sf(i, j, 0) = -sin(2._wp*pi*y_cc(j))/sqrt(4._wp*pi) q_prim_vf(B_idx%beg + 1)%sf(i, j, 0) = sin(4._wp*pi*x_cc(i))/sqrt(4._wp*pi) - case (251) ! RMHD Cylindrical Blast Wave [Mignone, 2006: Section 4.3.1] + case (251) ! RMHD Cylindrical Blast Wave [Mignone, 2006: Section 4.3.1] if (x_cc(i)**2 + y_cc(j)**2 < 0.08_wp**2) then q_prim_vf(contxb)%sf(i, j, 0) = 0.01 q_prim_vf(E_idx)%sf(i, j, 0) = 1.0 @@ -176,7 +174,7 @@ end if ! case 252 is for the 2D MHD Rotor problem - case (252) ! 2D MHD Rotor Problem + case (252) ! 2D MHD Rotor Problem ! Ambient conditions are set in the JSON file. This case imposes the dense, rotating cylinder. ! ! gamma = 1.4 Ambient medium (r > 0.1): rho = 1, p = 1, v = 0, B = (1,0,0) Rotor (r <= 0.1): rho = 10, p = 1 v has angular @@ -202,7 +200,7 @@ q_prim_vf(momxb)%sf(i, j, 0) = -(2._wp/sqrt(r_sq))*(y_cc(j) - 0.5_wp)*(0.115_wp - sqrt(r_sq))/(0.015_wp) q_prim_vf(momxb + 1)%sf(i, j, 0) = (2._wp/sqrt(r_sq))*(x_cc(i) - 0.5_wp)*(0.115_wp - sqrt(r_sq))/(0.015_wp) end if - case (253) ! MHD Smooth Magnetic Vortex + case (253) ! MHD Smooth Magnetic Vortex ! Section 5.2 of Implicit hybridized discontinuous Galerkin methods for compressible magnetohydrodynamics C. Ciuca, P. ! Fernandez, A. Christophe, N.C. Nguyen, J. Peraire @@ -217,7 +215,7 @@ ! pressure q_prim_vf(E_idx)%sf(i, j, & & 0) = 1._wp + (1 - 2._wp*(x_cc(i)**2 + y_cc(j)**2))*exp(1 - (x_cc(i)**2 + y_cc(j)**2))/((2._wp*pi)**3) - case (260) ! Gaussian Divergence Pulse + case (260) ! Gaussian Divergence Pulse ! Bx(x) = 1 + C * erf((x-0.5)/\sigma) => \partialBx/\partialx = C * (2/\sqrt\pi) * exp[-((x-0.5)/\sigma)**2] * (1/\sigma) ! Choose C = \epsilon * \sigma * \sqrt\pi / 2 => \partialBx/\partialx = \epsilon * exp[-((x-0.5)/\sigma)**2] \psi is ! initialized to zero everywhere. @@ -228,7 +226,7 @@ ! B-field q_prim_vf(B_idx%beg)%sf(i, j, 0) = 1._wp + C_mhd*erf((x_cc(i) - 0.5_wp)/sigma) - case (261) ! Blob + case (261) ! Blob r0 = 1._wp/sqrt(8._wp) r2 = x_cc(i)**2 + y_cc(j)**2 r = sqrt(r2) @@ -239,7 +237,7 @@ ! q_prim_vf(B_idx%beg)%sf(i,j,0) = 1._wp/(4._wp*pi) * (alpha**8 - 2._wp*alpha**4 + 1._wp) q_prim_vf(E_idx)%sf(i,j,0) = ! 6._wp - q_prim_vf(B_idx%beg)%sf(i,j,0)**2/2._wp end if - case (262) ! Tilted 2D MHD shock‐tube at α = arctan2 (≈63.4°) + case (262) ! Tilted 2D MHD shock‐tube at α = arctan2 (≈63.4°) ! rotate by \alpha = atan(2) alpha = atan(2._wp) cosA = cos(alpha) diff --git a/src/common/include/3dHardcodedIC.fpp b/src/common/include/3dHardcodedIC.fpp index b4ca939a49..f2d7e19ce2 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -7,13 +7,13 @@ real(wp), dimension(:), allocatable :: y_th_arr, z_th_arr, r_th_arr ! Variables to describe initial condition of jet real(wp) :: r, ux_th, ux_am, p_th, p_am, rho_th, rho_am, y_th, z_th, r_th, eps_smooth - real(wp) :: rcut, xcut ! Intermediate variables for creating smooth initial condition + real(wp) :: rcut, xcut ! Intermediate variables for creating smooth initial condition real(wp), dimension(0:n, 0:p) :: rcut_arr - integer :: l, q, s ! Iterators for reading input files - integer :: start, end ! Ints to keep track of position in file - character(len=1000) :: line ! String to store line in file - character(len=25) :: value ! String to store value in line - integer :: NJet ! Number of jets + integer :: l, q, s ! Iterators for reading input files + integer :: start, end ! Ints to keep track of position in file + character(len=1000) :: line ! String to store line in file + character(len=25) :: value ! String to store value in line + integer :: NJet ! Number of jets eps = 1e-9_wp @@ -29,19 +29,19 @@ open (unit=10, file="jets.csv", status="old", action="read") do q = 0, NJet - 1 - read (10, '(A)') line ! Read a full line as a string + read (10, '(A)') line ! Read a full line as a string start = 1 do l = 0, 2 - end = index(line(start:), ',') ! Find the next comma + end = index(line(start:), ',') ! Find the next comma if (end == 0) then - value = trim(adjustl(line(start:))) ! Last value in the line + value = trim(adjustl(line(start:))) ! Last value in the line else - value = trim(adjustl(line(start:start + end - 2))) ! Extract substring - start = start + end ! Move to next value + value = trim(adjustl(line(start:start + end - 2))) ! Extract substring + start = start + end ! Move to next value end if if (l == 0) then - read (value, *) y_th_arr(q) ! Convert string to numeric value + read (value, *) y_th_arr(q) ! Convert string to numeric value else if (l == 1) then read (value, *) z_th_arr(q) else @@ -66,7 +66,7 @@ #:def Hardcoded3D() select case (patch_icpp(patch_id)%hcid) - case (300) ! Rayleigh-Taylor instability + case (300) ! Rayleigh-Taylor instability rhoH = 3._wp rhoL = 1._wp pRef = 1.e5_wp @@ -97,7 +97,7 @@ pInt = pref + rhoH*9.81_wp*(1.2_wp - intH) q_prim_vf(E_idx)%sf(i, j, k) = pInt + rhoL*9.81_wp*(intH - y_cc(j)) end if - case (301) ! (3D lung geometry in X direction, |sin(*)+sin(*)|) + case (301) ! (3D lung geometry in X direction, |sin(*)+sin(*)|) h = 0.0_wp lam = 1.0_wp amp = patch_icpp(patch_id)%a(2) @@ -109,7 +109,7 @@ q_prim_vf(advxb)%sf(i, j, k) = patch_icpp(1)%alpha(1) q_prim_vf(advxe)%sf(i, j, k) = patch_icpp(1)%alpha(2) end if - case (302) ! 3D Jet with IGR + case (302) ! 3D Jet with IGR ux_th = 10*sqrt(1.4*0.4) ux_am = 0.0*sqrt(1.4) p_th = 2.0_wp @@ -139,7 +139,7 @@ end if q_prim_vf(E_idx)%sf(i, j, k) = p_th*rcut*xcut + p_am - case (303) ! 3D Multijet + case (303) ! 3D Multijet eps_smooth = 3.0_wp ux_th = 10*sqrt(1.4*0.4) ux_am = 2.5*sqrt(1.4*0.4) diff --git a/src/common/include/ExtrusionHardcodedIC.fpp b/src/common/include/ExtrusionHardcodedIC.fpp index 7a6fbeb0e8..0adb8beaa1 100644 --- a/src/common/include/ExtrusionHardcodedIC.fpp +++ b/src/common/include/ExtrusionHardcodedIC.fpp @@ -40,18 +40,18 @@ integer :: f, iter, ios, ios2, unit, unit2, idx, idy, index_x, index_y, jump, line_count, ycount real(wp) :: x_len, x_step, y_len, y_step real(wp) :: dummy_x, dummy_y, dummy_z, x0, y0 - integer :: global_offset_x, global_offset_y ! MPI subdomain offset + integer :: global_offset_x, global_offset_y ! MPI subdomain offset real(wp) :: delta_x, delta_y - character(len=100), dimension(sys_size) :: fileNames ! Arrays to store all data from files + character(len=100), dimension(sys_size) :: fileNames ! Arrays to store all data from files character(len=200) :: errmsg real(wp), allocatable :: stored_values(:,:,:) real(wp), allocatable :: x_coords(:), y_coords(:) logical :: files_loaded = .false. real(wp) :: domain_xstart, domain_xend, domain_ystart, domain_yend - character(len=*), parameter :: init_dir = "/home/MFC/FilesDirectory" ! For example /home/MFC/examples/1D_Shock/D/ - character(len=20) :: file_num_str ! For storing the file number as a string - character(len=20) :: zeros_part ! For the trailing zeros part - character(len=6), parameter :: zeros_default = "000000" ! Default zeros (can be changed) + character(len=*), parameter :: init_dir = "/home/MFC/FilesDirectory" ! For example /home/MFC/examples/1D_Shock/D/ + character(len=20) :: file_num_str ! For storing the file number as a string + character(len=20) :: zeros_part ! For the trailing zeros part + character(len=6), parameter :: zeros_default = "000000" ! Default zeros (can be changed) #:enddef #:def HardcodedReadValues() @@ -67,7 +67,7 @@ if (ios2 /= 0) call s_mpi_abort("Error opening file: " // trim(fileNames(1))) select case (num_dims) - case (1, 2) ! 1D and 2D cases are similar + case (1, 2) ! 1D and 2D cases are similar ! Count lines line_count = 0 do @@ -100,7 +100,7 @@ x_step = x_cc(1) - x_cc(0) delta_x = merge(x_cc(0) - domain_xstart + x_step/2.0, x_cc(index_x) - domain_xstart + x_step/2.0, num_dims == 1) global_offset_x = nint(abs(delta_x)/x_step) - case (3) ! 3D case - determine grid structure + case (3) ! 3D case - determine grid structure ! Find yRows by counting rows with same x read (unit2, *, iostat=ios2) x0, y0, dummy_z if (ios2 /= 0) call s_mpi_abort("Error reading first line") diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index d0df6786ef..4c93feaeb7 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -117,7 +117,7 @@ contains do l = 0, p do k = 0, n select case (int(bc_type(1, 2)%sf(0, k, l))) - case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP) ! Ghost-cell extrap. BC at end + case (BC_CHAR_SUP_OUTFLOW:BC_GHOST_EXTRAP) ! Ghost-cell extrap. BC at end call s_ghost_cell_extrapolation(q_prim_vf, 1, 1, k, l) case (BC_REFLECTIVE) call s_symmetry(q_prim_vf, 1, 1, k, l, pb_in, mv_in) @@ -281,42 +281,42 @@ contains integer, intent(in) :: k, l integer :: j, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then ! bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then ! bc_x%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l) end do end do - else !< bc_x%end + else !< bc_x%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l) end do end do end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l) end do end do - else !< bc_y%end + else !< bc_y%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l) end do end do end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0) end do end do - else !< bc_z%end + else !< bc_z%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p) @@ -338,8 +338,8 @@ contains integer, intent(in) :: k, l integer :: j, q, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !< bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then !< bc_x%beg do j = 1, buff_size do i = 1, contxe q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(j - 1, k, l) @@ -373,7 +373,7 @@ contains end do end do end if - else !< bc_x%end + else !< bc_x%end do j = 1, buff_size do i = 1, contxe q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l) @@ -407,8 +407,8 @@ contains end do end if end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do j = 1, buff_size do i = 1, momxb q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l) @@ -442,7 +442,7 @@ contains end do end do end if - else !< bc_y%end + else !< bc_y%end do j = 1, buff_size do i = 1, momxb q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l) @@ -477,8 +477,8 @@ contains end do end if end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do j = 1, buff_size do i = 1, momxb + 1 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, j - 1) @@ -512,7 +512,7 @@ contains end do end do end if - else !< bc_z%end + else !< bc_z%end do j = 1, buff_size do i = 1, momxb + 1 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p - (j - 1)) @@ -561,8 +561,8 @@ contains integer, intent(in) :: k, l integer :: j, q, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !< bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then !< bc_x%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l) @@ -579,7 +579,7 @@ contains end do end do end if - else !< bc_x%end + else !< bc_x%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(j - 1, k, l) @@ -597,8 +597,8 @@ contains end do end if end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l) @@ -615,7 +615,7 @@ contains end do end do end if - else !< bc_y%end + else !< bc_y%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, j - 1, l) @@ -633,8 +633,8 @@ contains end do end if end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, p - (j - 1)) @@ -651,7 +651,7 @@ contains end do end do end if - else !< bc_z%end + else !< bc_z%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, j - 1) @@ -733,8 +733,8 @@ contains integer, intent(in) :: k, l integer :: j, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !< bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then !< bc_x%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb) then @@ -744,7 +744,7 @@ contains end if end do end do - else !< bc_x%end + else !< bc_x%end do i = 1, sys_size do j = 1, buff_size if (i == momxb) then @@ -755,8 +755,8 @@ contains end do end do end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb + 1) then @@ -766,7 +766,7 @@ contains end if end do end do - else !< bc_y%end + else !< bc_y%end do i = 1, sys_size do j = 1, buff_size if (i == momxb + 1) then @@ -777,8 +777,8 @@ contains end do end do end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size if (i == momxe) then @@ -788,7 +788,7 @@ contains end if end do end do - else !< bc_z%end + else !< bc_z%end do i = 1, sys_size do j = 1, buff_size if (i == momxe) then @@ -813,8 +813,8 @@ contains integer, intent(in) :: k, l integer :: j, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then !< bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then !< bc_x%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb) then @@ -828,7 +828,7 @@ contains end if end do end do - else !< bc_x%end + else !< bc_x%end do i = 1, sys_size do j = 1, buff_size if (i == momxb) then @@ -843,8 +843,8 @@ contains end do end do end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb) then @@ -858,7 +858,7 @@ contains end if end do end do - else !< bc_y%end + else !< bc_y%end do i = 1, sys_size do j = 1, buff_size if (i == momxb) then @@ -873,8 +873,8 @@ contains end do end do end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size if (i == momxb) then @@ -888,7 +888,7 @@ contains end if end do end do - else !< bc_z%end + else !< bc_z%end do i = 1, sys_size do j = 1, buff_size if (i == momxb) then @@ -917,29 +917,29 @@ contains integer :: j, i #ifdef MFC_SIMULATION - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then ! bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then ! bc_x%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(-j, k, l) = bc_buffers(1, 1)%sf(i, k, l) end do end do - else !< bc_x%end + else !< bc_x%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(m + j, k, l) = bc_buffers(1, 2)%sf(i, k, l) end do end do end if - else if (bc_dir == 2) then !< y-direction + else if (bc_dir == 2) then !< y-direction #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (bc_loc == -1) then !< bc_y%beg + if (bc_loc == -1) then !< bc_y%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, -j, l) = bc_buffers(2, 1)%sf(k, i, l) end do end do - else !< bc_y%end + else !< bc_y%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, n + j, l) = bc_buffers(2, 2)%sf(k, i, l) @@ -947,15 +947,15 @@ contains end do end if #:endif - else if (bc_dir == 3) then !< z-direction + else if (bc_dir == 3) then !< z-direction #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (bc_loc == -1) then !< bc_z%beg + if (bc_loc == -1) then !< bc_z%beg do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, l, -j) = bc_buffers(3, 1)%sf(k, l, i) end do end do - else !< bc_z%end + else !< bc_z%end do i = 1, sys_size do j = 1, buff_size q_prim_vf(i)%sf(k, l, p + j) = bc_buffers(3, 2)%sf(k, l, i) @@ -979,8 +979,8 @@ contains integer, intent(in) :: k, l integer :: j, q, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then ! bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then ! bc_x%beg do i = 1, nb do q = 1, nnode do j = 1, buff_size @@ -989,7 +989,7 @@ contains end do end do end do - else !< bc_x%end + else !< bc_x%end do i = 1, nb do q = 1, nnode do j = 1, buff_size @@ -999,8 +999,8 @@ contains end do end do end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do i = 1, nb do q = 1, nnode do j = 1, buff_size @@ -1009,7 +1009,7 @@ contains end do end do end do - else !< bc_y%end + else !< bc_y%end do i = 1, nb do q = 1, nnode do j = 1, buff_size @@ -1019,8 +1019,8 @@ contains end do end do end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do i = 1, nb do q = 1, nnode do j = 1, buff_size @@ -1029,7 +1029,7 @@ contains end do end do end do - else !< bc_z%end + else !< bc_z%end do i = 1, nb do q = 1, nnode do j = 1, buff_size @@ -1187,42 +1187,42 @@ contains integer, intent(in) :: k, l integer :: j, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then ! bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then ! bc_x%beg do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(m - (j - 1), k, l) end do end do - else !< bc_x%end + else !< bc_x%end do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(m + j, k, l) = c_divs(i)%sf(j - 1, k, l) end do end do end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(k, -j, l) = c_divs(i)%sf(k, n - (j - 1), l) end do end do - else !< bc_y%end + else !< bc_y%end do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(k, n + j, l) = c_divs(i)%sf(k, j - 1, l) end do end do end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(k, l, -j) = c_divs(i)%sf(k, l, p - (j - 1)) end do end do - else !< bc_z%end + else !< bc_z%end do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(k, l, p + j) = c_divs(i)%sf(k, l, j - 1) @@ -1242,8 +1242,8 @@ contains integer, intent(in) :: k, l integer :: j, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then ! bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then ! bc_x%beg do i = 1, num_dims + 1 do j = 1, buff_size if (i == bc_dir) then @@ -1253,7 +1253,7 @@ contains end if end do end do - else !< bc_x%end + else !< bc_x%end do i = 1, num_dims + 1 do j = 1, buff_size if (i == bc_dir) then @@ -1264,8 +1264,8 @@ contains end do end do end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do i = 1, num_dims + 1 do j = 1, buff_size if (i == bc_dir) then @@ -1275,7 +1275,7 @@ contains end if end do end do - else !< bc_y%end + else !< bc_y%end do i = 1, num_dims + 1 do j = 1, buff_size if (i == bc_dir) then @@ -1286,8 +1286,8 @@ contains end do end do end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do i = 1, num_dims + 1 do j = 1, buff_size if (i == bc_dir) then @@ -1297,7 +1297,7 @@ contains end if end do end do - else !< bc_z%end + else !< bc_z%end do i = 1, num_dims + 1 do j = 1, buff_size if (i == bc_dir) then @@ -1321,42 +1321,42 @@ contains integer, intent(in) :: k, l integer :: j, i - if (bc_dir == 1) then !< x-direction - if (bc_loc == -1) then ! bc_x%beg + if (bc_dir == 1) then !< x-direction + if (bc_loc == -1) then ! bc_x%beg do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(0, k, l) end do end do - else !< bc_x%end + else !< bc_x%end do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(m + j, k, l) = c_divs(i)%sf(m, k, l) end do end do end if - else if (bc_dir == 2) then !< y-direction - if (bc_loc == -1) then !< bc_y%beg + else if (bc_dir == 2) then !< y-direction + if (bc_loc == -1) then !< bc_y%beg do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(k, -j, l) = c_divs(i)%sf(k, 0, l) end do end do - else !< bc_y%end + else !< bc_y%end do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(k, n + j, l) = c_divs(i)%sf(k, n, l) end do end do end if - else if (bc_dir == 3) then !< z-direction - if (bc_loc == -1) then !< bc_z%beg + else if (bc_dir == 3) then !< z-direction + if (bc_loc == -1) then !< bc_z%beg do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(k, l, -j) = c_divs(i)%sf(k, l, 0) end do end do - else !< bc_z%end + else !< bc_z%end do i = 1, num_dims + 1 do j = 1, buff_size c_divs(i)%sf(k, l, p + j) = c_divs(i)%sf(k, l, p) diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index ec03cd9c7f..a828dfe596 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -35,7 +35,7 @@ contains !> @brief Verifies that the total number of grid cells meets the minimum required by the number of dimensions and MPI ranks. impure subroutine s_check_total_cells - character(len=18) :: numStr !< for int to string conversion + character(len=18) :: numStr !< for int to string conversion integer(kind=8) :: min_cells min_cells = int(2, kind=8)**int(min(1, m) + min(1, n) + min(1, p), kind=8)*int(num_procs, kind=8) diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index b5b86c111c..bba8d62f74 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -61,9 +61,9 @@ impure subroutine my_inquire(fileloc, dircheck) logical, intent(inout) :: dircheck #ifdef __INTEL_COMPILER - inquire (DIRECTORY=trim(fileloc), EXIST=dircheck) ! Intel + inquire (DIRECTORY=trim(fileloc), EXIST=dircheck) ! Intel #else - inquire (FILE=trim(fileloc), EXIST=dircheck) ! GCC + inquire (FILE=trim(fileloc), EXIST=dircheck) ! GCC #endif end subroutine my_inquire diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index a9dc7bbd6e..789a5960eb 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -7,86 +7,86 @@ module m_constants use m_precision_select - character, parameter :: dflt_char = ' ' !< Default string value - real(wp), parameter :: dflt_real = -1.e6_wp !< Default real value - real(wp), parameter :: sgm_eps = 1.e-16_wp !< Segmentation tolerance - real(wp), parameter :: Chem_Tolerance = 1.e-16_wp !< Speed of Sound Tolerance in Chemistry - real(wp), parameter :: small_alf = 1.e-11_wp !< Small alf tolerance - real(wp), parameter :: pi = 3.141592653589793_wp !< Pi - real(wp), parameter :: verysmall = 1.e-12_wp !< Very small number + character, parameter :: dflt_char = ' ' !< Default string value + real(wp), parameter :: dflt_real = -1.e6_wp !< Default real value + real(wp), parameter :: sgm_eps = 1.e-16_wp !< Segmentation tolerance + real(wp), parameter :: Chem_Tolerance = 1.e-16_wp !< Speed of Sound Tolerance in Chemistry + real(wp), parameter :: small_alf = 1.e-11_wp !< Small alf tolerance + real(wp), parameter :: pi = 3.141592653589793_wp !< Pi + real(wp), parameter :: verysmall = 1.e-12_wp !< Very small number !> Radius cutoff to avoid division by zero for 3D spherical harmonic patch (geometry 14) real(wp), parameter :: small_radius = 1.e-32_wp - integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils - integer, parameter :: path_len = 400 !< Maximum path length - integer, parameter :: name_len = 50 !< Maximum name length - integer, parameter :: dflt_int = -100 !< Default integer value - integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit - integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation - integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation - integer, parameter :: num_patches_max = 1000 !< Maximum number of IC patches - integer, parameter :: num_bc_patches_max = 10 !< Maximum number of boundary condition patches - integer, parameter :: max_2d_fourier_modes = 10 !< Max Fourier mode index for 2D modal patch (geometry 13) - integer, parameter :: max_sph_harm_degree = 5 !< Max degree L for 3D spherical harmonic patch (geometry 14) - integer, parameter :: pathlen_max = 400 !< Maximum path length for STL/OBJ model files - integer, parameter :: nnode = 4 !< Number of QBMM nodes - integer, parameter :: dflt_num_igr_iters = 2 !< number of iterations for IGR elliptic solve - integer, parameter :: dflt_num_igr_warm_start_iters = 50 !< default number of iterations for IGR elliptic solve - real(wp), parameter :: dflt_alf_factor = 10._wp !< scaling factor for IGR alpha - integer, parameter :: gp_layers = 3 !< Number of ghost point layers for IBM + integer, parameter :: num_stcls_min = 5 !< Minimum # of stencils + integer, parameter :: path_len = 400 !< Maximum path length + integer, parameter :: name_len = 50 !< Maximum name length + integer, parameter :: dflt_int = -100 !< Default integer value + integer, parameter :: fourier_rings = 5 !< Fourier filter ring limit + integer, parameter :: num_fluids_max = 10 !< Maximum number of fluids in the simulation + integer, parameter :: num_probes_max = 10 !< Maximum number of flow probes in the simulation + integer, parameter :: num_patches_max = 1000 !< Maximum number of IC patches + integer, parameter :: num_bc_patches_max = 10 !< Maximum number of boundary condition patches + integer, parameter :: max_2d_fourier_modes = 10 !< Max Fourier mode index for 2D modal patch (geometry 13) + integer, parameter :: max_sph_harm_degree = 5 !< Max degree L for 3D spherical harmonic patch (geometry 14) + integer, parameter :: pathlen_max = 400 !< Maximum path length for STL/OBJ model files + integer, parameter :: nnode = 4 !< Number of QBMM nodes + integer, parameter :: dflt_num_igr_iters = 2 !< number of iterations for IGR elliptic solve + integer, parameter :: dflt_num_igr_warm_start_iters = 50 !< default number of iterations for IGR elliptic solve + real(wp), parameter :: dflt_alf_factor = 10._wp !< scaling factor for IGR alpha + integer, parameter :: gp_layers = 3 !< Number of ghost point layers for IBM !> color function gradient magnitude at which to apply the surface tension fluxes real(wp), parameter :: capillary_cutoff = 1.e-6 !> Spatial support width of acoustic source, used in s_source_spatial real(wp), parameter :: acoustic_spatial_support_width = 2.5_wp - real(wp), parameter :: dflt_vcfl_dt = 100._wp !< value of vcfl_dt when viscosity is off for computing adaptive timestep size + real(wp), parameter :: dflt_vcfl_dt = 100._wp !< value of vcfl_dt when viscosity is off for computing adaptive timestep size !> The constant to scale the spectral level at the lower frequency bound real(wp), parameter :: broadband_spectral_level_constant = 20._wp !> The spectral level constant to correct the magnitude at each frequency to ensure the source is overall broadband real(wp), parameter :: broadband_spectral_level_growth_rate = 10._wp ! Reconstruction Types - integer, parameter :: WENO_TYPE = 1 !< Using WENO for reconstruction type - integer, parameter :: MUSCL_TYPE = 2 !< Using MUSCL for reconstruction type + integer, parameter :: WENO_TYPE = 1 !< Using WENO for reconstruction type + integer, parameter :: MUSCL_TYPE = 2 !< Using MUSCL for reconstruction type ! Interface Compression - real(wp), parameter :: dflt_ic_eps = 1e-4_wp !< Ensure compression is only applied to surface cells in THINC - real(wp), parameter :: dflt_ic_beta = 1.6_wp !< Sharpness parameter's default value used in THINC - real(wp), parameter :: moncon_cutoff = 1e-8_wp !< Monotonicity constraint's limiter to prevent extremas in THINC + real(wp), parameter :: dflt_ic_eps = 1e-4_wp !< Ensure compression is only applied to surface cells in THINC + real(wp), parameter :: dflt_ic_beta = 1.6_wp !< Sharpness parameter's default value used in THINC + real(wp), parameter :: moncon_cutoff = 1e-8_wp !< Monotonicity constraint's limiter to prevent extremas in THINC ! Chemistry - real(wp), parameter :: dflt_T_guess = 1200._wp ! Default guess for temperature (when a previous value is not available) + real(wp), parameter :: dflt_T_guess = 1200._wp ! Default guess for temperature (when a previous value is not available) ! IBM+STL interpolation constants - integer, parameter :: num_ray = 20 !< Default number of rays traced per cell - real(wp), parameter :: ray_tracing_threshold = 0.9_wp !< Threshold above which the cell is marked as the model patch - real(wp), parameter :: threshold_vector_zero = 1.e-10_wp !< Threshold to treat the component of a vector to be zero - real(wp), parameter :: threshold_edge_zero = 1.e-10_wp !< Threshold to treat two edges to be overlapped - real(wp), parameter :: initial_distance_buffer = 1.e12_wp !< Initialized levelset distance for the shortest path pair algorithm + integer, parameter :: num_ray = 20 !< Default number of rays traced per cell + real(wp), parameter :: ray_tracing_threshold = 0.9_wp !< Threshold above which the cell is marked as the model patch + real(wp), parameter :: threshold_vector_zero = 1.e-10_wp !< Threshold to treat the component of a vector to be zero + real(wp), parameter :: threshold_edge_zero = 1.e-10_wp !< Threshold to treat two edges to be overlapped + real(wp), parameter :: initial_distance_buffer = 1.e12_wp !< Initialized levelset distance for the shortest path pair algorithm ! Lagrange bubbles constants - integer, parameter :: mapCells = 3 !< Number of cells around the bubble where the smoothening function will have effect - real(wp), parameter :: R_uni = 8314._wp !< Universal gas constant - J/kmol/K - integer, parameter :: lag_io_vars = 21 ! Number of variables per particle for MPI_IO + integer, parameter :: mapCells = 3 !< Number of cells around the bubble where the smoothening function will have effect + real(wp), parameter :: R_uni = 8314._wp !< Universal gas constant - J/kmol/K + integer, parameter :: lag_io_vars = 21 ! Number of variables per particle for MPI_IO ! Strang Splitting constants - real(wp), parameter :: dflt_adap_dt_tol = 1.e-4_wp !< Default tolerance for adaptive step size - integer, parameter :: dflt_adap_dt_max_iters = 100 !< Default max iteration for adaptive step size + real(wp), parameter :: dflt_adap_dt_tol = 1.e-4_wp !< Default tolerance for adaptive step size + integer, parameter :: dflt_adap_dt_max_iters = 100 !< Default max iteration for adaptive step size ! Constants of the algorithm described by Heirer, E. Hairer, S. P.Norsett, G. Wanner, Solving Ordinary Differential Equations I, ! Chapter II.4 to choose the initial time step size for the adaptive time stepping routine - real(wp), parameter :: threshold_first_guess = 1.e-5_wp !< Threshold for initial step size estimate - real(wp), parameter :: threshold_second_guess = 1.e-15_wp !< Threshold for refined step size estimate - real(wp), parameter :: scale_first_guess = 1.e-3_wp !< Scale factor for initial step size - real(wp), parameter :: scale_guess = 1.e-2_wp !< Scale factor for step size adjustment - real(wp), parameter :: small_guess = 1.e-6_wp !< Minimum initial step size + real(wp), parameter :: threshold_first_guess = 1.e-5_wp !< Threshold for initial step size estimate + real(wp), parameter :: threshold_second_guess = 1.e-15_wp !< Threshold for refined step size estimate + real(wp), parameter :: scale_first_guess = 1.e-3_wp !< Scale factor for initial step size + real(wp), parameter :: scale_guess = 1.e-2_wp !< Scale factor for step size adjustment + real(wp), parameter :: small_guess = 1.e-6_wp !< Minimum initial step size ! Relativity !> Max Newton-Raphson iterations for relativistic primitive recovery integer, parameter :: relativity_cons_to_prim_max_iter = 100 ! Linear congruential pseudo-random number generator parameters - integer, parameter :: modulus = 2**30 - 1 !< PRNG modulus - integer, parameter :: multiplier = 1664525 !< PRNG multiplier - integer, parameter :: increment = 1013904223 !< PRNG increment - integer, parameter :: amplifier = 3**13 !< PRNG amplifier for mixing - real(wp), parameter :: decimal_trim = 1.e5_wp !< PRNG decimal truncation factor + integer, parameter :: modulus = 2**30 - 1 !< PRNG modulus + integer, parameter :: multiplier = 1664525 !< PRNG multiplier + integer, parameter :: increment = 1013904223 !< PRNG increment + integer, parameter :: amplifier = 3**13 !< PRNG amplifier for mixing + real(wp), parameter :: decimal_trim = 1.e5_wp !< PRNG decimal truncation factor ! System constants - integer, parameter :: CASE_FILE_ERROR_CODE = 22 !< Exit code for case file validation errors + integer, parameter :: CASE_FILE_ERROR_CODE = 22 !< Exit code for case file validation errors ! Boundary condition enumeration Abbreviations CHAR - Characteristic NR - Non-reflecting SUB - subsonic SUP - supersonic FF - ! Force-free CP - Constant pressure diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 0ed66761c2..39667a758d 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -15,7 +15,7 @@ module m_derived_types !> Derived type adding the field position (fp) as an attribute type field_position - real(stp), allocatable, dimension(:,:,:) :: fp !< Field position + real(stp), allocatable, dimension(:,:,:) :: fp !< Field position end type field_position !> Derived type annexing a scalar field (SF) @@ -69,12 +69,12 @@ module m_derived_types !> Derived type annexing a vector field (VF) type vector_field - type(scalar_field), allocatable, dimension(:) :: vf !< Vector field + type(scalar_field), allocatable, dimension(:) :: vf !< Vector field end type vector_field !> Generic 3-component vector (e.g., spatial coordinates or field components) Named _dt (derived types: x,y,z) to differentiate !! from t_vec3 (3-component vector) - type vec3_dt ! dt for derived types + type vec3_dt ! dt for derived types real(wp) :: x real(wp) :: y real(wp) :: z @@ -132,38 +132,38 @@ module m_derived_types integer, dimension(:), allocatable :: vs integer, dimension(:), allocatable :: ps integer, dimension(:), allocatable :: ms - integer, dimension(:,:), allocatable :: moms !< Moment indices for qbmm - integer, dimension(:,:,:), allocatable :: fullmom !< Moment indices for qbmm + integer, dimension(:,:), allocatable :: moms !< Moment indices for qbmm + integer, dimension(:,:,:), allocatable :: fullmom !< Moment indices for qbmm end type bub_bounds_info !> Defines parameters for a Model Patch type ic_model_parameters - character(LEN=pathlen_max) :: filepath !< Path the STL file relative to case_dir. - real(wp), dimension(1:3) :: translate !< Translation of the STL object. - real(wp), dimension(1:3) :: scale !< Scale factor for the STL object. - real(wp), dimension(1:3) :: rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. - integer :: spc !< Number of samples per cell to use when discretizing the STL object. - real(wp) :: threshold !< Threshold to turn on smoothen STL patch. + character(LEN=pathlen_max) :: filepath !< Path the STL file relative to case_dir. + real(wp), dimension(1:3) :: translate !< Translation of the STL object. + real(wp), dimension(1:3) :: scale !< Scale factor for the STL object. + real(wp), dimension(1:3) :: rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + integer :: spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: threshold !< Threshold to turn on smoothen STL patch. end type ic_model_parameters type :: t_triangle - real(wp), dimension(1:3, 1:3) :: v ! Vertices of the triangle - real(wp), dimension(1:3) :: n ! Normal vector + real(wp), dimension(1:3, 1:3) :: v ! Vertices of the triangle + real(wp), dimension(1:3) :: n ! Normal vector end type t_triangle type :: t_ray - real(wp), dimension(1:3) :: o ! Origin - real(wp), dimension(1:3) :: d ! Direction + real(wp), dimension(1:3) :: o ! Origin + real(wp), dimension(1:3) :: d ! Direction end type t_ray type :: t_bbox - real(wp), dimension(1:3) :: min ! Minimum coordinates - real(wp), dimension(1:3) :: max ! Maximum coordinates + real(wp), dimension(1:3) :: min ! Minimum coordinates + real(wp), dimension(1:3) :: max ! Maximum coordinates end type t_bbox type :: t_model - integer :: ntrs ! Number of triangles - type(t_triangle), allocatable :: trs(:) ! Triangles + integer :: ntrs ! Number of triangles + type(t_triangle), allocatable :: trs(:) ! Triangles end type t_model type :: t_model_array @@ -176,9 +176,9 @@ module m_derived_types integer :: interpolate ! GPU-friendly flattened arrays - integer :: ntrs ! copy of model%ntrs - real(wp), allocatable, dimension(:,:,:) :: trs_v ! (3, 3, ntrs) - triangle vertices - real(wp), allocatable, dimension(:,:) :: trs_n ! (3, ntrs) - triangle normals + integer :: ntrs ! copy of model%ntrs + real(wp), allocatable, dimension(:,:,:) :: trs_v ! (3, 3, ntrs) - triangle vertices + real(wp), allocatable, dimension(:,:) :: trs_n ! (3, ntrs) - triangle normals end type t_model_array !> Derived type adding initial condition (ic) patch parameters as attributes NOTE: The requirements for the specification of the @@ -186,23 +186,23 @@ module m_derived_types !! patch geometry. type ic_patch_parameters - integer :: geometry !< Type of geometry for the patch + integer :: geometry !< Type of geometry for the patch !> Location of the geometric center, i.e. the centroid, of the patch. It is specified through its x-, y- and z-coordinates, !! respectively. real(wp) :: x_centroid, y_centroid, z_centroid - real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. + real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. + real(wp) :: radius !< Dimensions of the patch. radius. !> Vector indicating the various radii for the elliptical and ellipsoidal patch geometries. It is specified through its x-, !! y-, and z-components respectively. real(wp), dimension(3) :: radii - real(wp) :: epsilon, beta !< The isentropic vortex parameters for the amplitude of the disturbance and domain of influence. - real(wp), dimension(2:9) :: a !< Used by hardcoded IC and as temporary variables. + real(wp) :: epsilon, beta !< The isentropic vortex parameters for the amplitude of the disturbance and domain of influence. + real(wp), dimension(2:9) :: a !< Used by hardcoded IC and as temporary variables. logical :: non_axis_sym ! Geometry 13 (2D modal Fourier): fourier_cos(n), fourier_sin(n) for mode n real(wp), dimension(1:max_2d_fourier_modes) :: fourier_cos, fourier_sin - logical :: modal_clip_r_to_min !< When true, clip boundary radius: R(theta) = max(R(theta), modal_r_min) (Non-exp form only) - real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) + logical :: modal_clip_r_to_min !< When true, clip boundary radius: R(theta) = max(R(theta), modal_r_min) (Non-exp form only) + real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) ! Geometry 14 (3D spherical harmonic): sph_har_coeff(l,m) for real Y_lm real(wp), dimension(0:max_sph_harm_degree, -max_sph_harm_degree:max_sph_harm_degree) :: sph_har_coeff @@ -214,7 +214,7 @@ module m_derived_types !> Permission indicating to the current patch whether its boundaries will be smoothed out across a few cells or whether they !! are to remain sharp logical :: smoothen - integer :: smooth_patch_id !< Identity (id) of the patch with which current patch is to get smoothed + integer :: smooth_patch_id !< Identity (id) of the patch with which current patch is to get smoothed !> Smoothing coefficient (coeff) for the size of the stencil of cells across which boundaries of the current patch will be !! smeared out real(wp) :: smooth_coeff @@ -230,12 +230,12 @@ module m_derived_types !> Primitive variables associated with the patch. In order, these include the partial densities, density, velocity, !! pressure, volume fractions, specific heat ratio function and the liquid stiffness function. real(wp) :: qvp - real(wp) :: Bx, By, Bz !< Magnetic field components; B%x is not used for 1D - real(wp), dimension(6) :: tau_e !< Elastic stresses added to primitive variables if hypoelasticity = True - real(wp) :: R0 !< Bubble size - real(wp) :: V0 !< Bubble velocity - real(wp) :: p0 !< Bubble size - real(wp) :: m0 !< Bubble velocity + real(wp) :: Bx, By, Bz !< Magnetic field components; B%x is not used for 1D + real(wp), dimension(6) :: tau_e !< Elastic stresses added to primitive variables if hypoelasticity = True + real(wp) :: R0 !< Bubble size + real(wp) :: V0 !< Bubble velocity + real(wp) :: p0 !< Bubble size + real(wp) :: m0 !< Bubble velocity integer :: hcid !! id for hard coded initial condition @@ -243,84 +243,84 @@ module m_derived_types real(wp) :: Y(1:num_species) !! STL or OBJ model input parameter - character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. - real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. - real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. - real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. - integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. - real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. + character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. + real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. + real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. + real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. end type ic_patch_parameters type ib_patch_parameters - integer :: geometry !< Type of geometry for the patch + integer :: geometry !< Type of geometry for the patch !> Location of the geometric center, i.e. the centroid, of the patch. It is specified through its x-, y- and z-coordinates, !! respectively. real(wp) :: x_centroid, y_centroid, z_centroid !> Centroid locations of intermediate steps in the time_stepper module real(wp) :: step_x_centroid, step_y_centroid, step_z_centroid - real(wp), dimension(1:3) :: centroid_offset ! offset of center of mass from computed cell center for odd-shaped IBs + real(wp), dimension(1:3) :: centroid_offset ! offset of center of mass from computed cell center for odd-shaped IBs real(wp), dimension(1:3) :: angles real(wp), dimension(1:3) :: step_angles - real(wp), dimension(1:3, 1:3) :: rotation_matrix !< matrix that converts from IB reference frame to fluid reference frame + real(wp), dimension(1:3, 1:3) :: rotation_matrix !< matrix that converts from IB reference frame to fluid reference frame !> matrix that converts from fluid reference frame to IB reference frame real(wp), dimension(1:3, 1:3) :: rotation_matrix_inverse real(wp) :: c, p, t, m - real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. + real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. + real(wp) :: radius !< Dimensions of the patch. radius. real(wp) :: theta logical :: slip !! STL or OBJ model input parameter - character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. - real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. - real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. - real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. - integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. - real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. Patch conditions for moving imersed boundaries - integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path - real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling - real(wp), dimension(1:3) :: force, torque ! vectors for the computed force and torque values applied to an IB + character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. + real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. + real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. + real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. Patch conditions for moving imersed boundaries + integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path + real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling + real(wp), dimension(1:3) :: force, torque ! vectors for the computed force and torque values applied to an IB real(wp), dimension(1:3) :: vel - real(wp), dimension(1:3) :: step_vel ! velocity array used to store intermediate steps in the time_stepper module + real(wp), dimension(1:3) :: step_vel ! velocity array used to store intermediate steps in the time_stepper module real(wp), dimension(1:3) :: angular_vel - real(wp), dimension(1:3) :: step_angular_vel ! velocity array used to store intermediate steps in the time_stepper module + real(wp), dimension(1:3) :: step_angular_vel ! velocity array used to store intermediate steps in the time_stepper module end type ib_patch_parameters !> Derived type annexing the physical parameters (PP) of the fluids. These include the specific heat ratio function and liquid !! stiffness function. type physical_parameters - real(wp) :: gamma !< Sp. heat ratio - real(wp) :: pi_inf !< Liquid stiffness - real(wp), dimension(2) :: Re !< Reynolds number - real(wp) :: cv !< heat capacity - real(wp) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) - real(wp) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) + real(wp) :: gamma !< Sp. heat ratio + real(wp) :: pi_inf !< Liquid stiffness + real(wp), dimension(2) :: Re !< Reynolds number + real(wp) :: cv !< heat capacity + real(wp) :: qv !< reference energy per unit mass for SGEOS, q (see Le Metayer (2004)) + real(wp) :: qvp !< reference entropy per unit mass for SGEOS, q' (see Le Metayer (2004)) real(wp) :: G end type physical_parameters !> Derived type annexing the physical parameters required for sub-grid bubble models type subgrid_bubble_physical_parameters - real(wp) :: R0ref !< reference bubble radius - real(wp) :: p0ref !< reference pressure - real(wp) :: rho0ref !< reference density - real(wp) :: T0ref !< reference temperature - real(wp) :: ss !< surface tension between host and gas (bubble) - real(wp) :: pv !< vapor pressure of host - real(wp) :: vd !< vapor diffusivity in gas (bubble) - real(wp) :: mu_l !< viscosity of host in liquid state - real(wp) :: mu_v !< viscosity of host in vapor state - real(wp) :: mu_g !< viscosity of gas (bubble) - real(wp) :: gam_v !< specific heat ratio of host in vapor state - real(wp) :: gam_g !< specific heat ratio of gas (bubble) - real(wp) :: M_v !< Molecular weight of host - real(wp) :: M_g !< Molecular weight of gas (bubble) - real(wp) :: k_v !< thermal conductivity of host in vapor state - real(wp) :: k_g !< thermal conductivity of gas (bubble) - real(wp) :: cp_v !< specific heat capacity in constant pressure of host in vapor state - real(wp) :: cp_g !< specific heat capacity in constant pressure of gas (bubble) - real(wp) :: R_v !< gas constant of host in vapor state - real(wp) :: R_g !< gas constant of gas (bubble) + real(wp) :: R0ref !< reference bubble radius + real(wp) :: p0ref !< reference pressure + real(wp) :: rho0ref !< reference density + real(wp) :: T0ref !< reference temperature + real(wp) :: ss !< surface tension between host and gas (bubble) + real(wp) :: pv !< vapor pressure of host + real(wp) :: vd !< vapor diffusivity in gas (bubble) + real(wp) :: mu_l !< viscosity of host in liquid state + real(wp) :: mu_v !< viscosity of host in vapor state + real(wp) :: mu_g !< viscosity of gas (bubble) + real(wp) :: gam_v !< specific heat ratio of host in vapor state + real(wp) :: gam_g !< specific heat ratio of gas (bubble) + real(wp) :: M_v !< Molecular weight of host + real(wp) :: M_g !< Molecular weight of gas (bubble) + real(wp) :: k_v !< thermal conductivity of host in vapor state + real(wp) :: k_g !< thermal conductivity of gas (bubble) + real(wp) :: cp_v !< specific heat capacity in constant pressure of host in vapor state + real(wp) :: cp_g !< specific heat capacity in constant pressure of gas (bubble) + real(wp) :: R_v !< gas constant of host in vapor state + real(wp) :: R_g !< gas constant of gas (bubble) end type subgrid_bubble_physical_parameters type mpi_io_airfoil_ib_var @@ -330,58 +330,58 @@ module m_derived_types !> Derived type annexing integral regions type integral_parameters - real(wp) :: xmin !< Min. boundary first coordinate direction - real(wp) :: xmax !< Max. boundary first coordinate direction - real(wp) :: ymin !< Min. boundary second coordinate direction - real(wp) :: ymax !< Max. boundary second coordinate direction - real(wp) :: zmin !< Min. boundary third coordinate direction - real(wp) :: zmax !< Max. boundary third coordinate direction + real(wp) :: xmin !< Min. boundary first coordinate direction + real(wp) :: xmax !< Max. boundary first coordinate direction + real(wp) :: ymin !< Min. boundary second coordinate direction + real(wp) :: ymax !< Max. boundary second coordinate direction + real(wp) :: zmin !< Min. boundary third coordinate direction + real(wp) :: zmax !< Max. boundary third coordinate direction end type integral_parameters !> Acoustic source parameters type acoustic_parameters - integer :: pulse !< Type of pulse - integer :: support !< Type of support - logical :: dipole !< Whether the source is a dipole or monopole - real(wp), dimension(3) :: loc !< Physical location of acoustic source - real(wp) :: mag !< Acoustic pulse magnitude - real(wp) :: length !< Length of planar source (2D/3D) - real(wp) :: height !< Height of planar source (3D) - real(wp) :: wavelength !< Wave length of pulse - real(wp) :: frequency !< Frequency of pulse - real(wp) :: gauss_sigma_dist !< sigma of Gaussian pulse multiplied by speed of sound - real(wp) :: gauss_sigma_time !< sigma of Gaussian pulse - real(wp) :: npulse !< Number of cycles of pulse - real(wp) :: dir !< Direction of pulse - real(wp) :: delay !< Time-delay of pulse start - real(wp) :: foc_length ! < Focal length of transducer - real(wp) :: aperture ! < Aperture diameter of transducer - real(wp) :: element_spacing_angle !< Spacing between aperture elements in 2D acoustic array + integer :: pulse !< Type of pulse + integer :: support !< Type of support + logical :: dipole !< Whether the source is a dipole or monopole + real(wp), dimension(3) :: loc !< Physical location of acoustic source + real(wp) :: mag !< Acoustic pulse magnitude + real(wp) :: length !< Length of planar source (2D/3D) + real(wp) :: height !< Height of planar source (3D) + real(wp) :: wavelength !< Wave length of pulse + real(wp) :: frequency !< Frequency of pulse + real(wp) :: gauss_sigma_dist !< sigma of Gaussian pulse multiplied by speed of sound + real(wp) :: gauss_sigma_time !< sigma of Gaussian pulse + real(wp) :: npulse !< Number of cycles of pulse + real(wp) :: dir !< Direction of pulse + real(wp) :: delay !< Time-delay of pulse start + real(wp) :: foc_length ! < Focal length of transducer + real(wp) :: aperture ! < Aperture diameter of transducer + real(wp) :: element_spacing_angle !< Spacing between aperture elements in 2D acoustic array !> Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array real(wp) :: element_polygon_ratio - real(wp) :: rotate_angle !< Angle of rotation of the entire circular 3D acoustic array - real(wp) :: bb_bandwidth !< Bandwidth of each frequency in broadband wave - real(wp) :: bb_lowest_freq !< The lower frequency bound of broadband wave - integer :: num_elements !< Number of elements in the acoustic array - integer :: element_on !< Element in the acoustic array to turn on - integer :: bb_num_freq !< Number of frequencies in the broadband wave + real(wp) :: rotate_angle !< Angle of rotation of the entire circular 3D acoustic array + real(wp) :: bb_bandwidth !< Bandwidth of each frequency in broadband wave + real(wp) :: bb_lowest_freq !< The lower frequency bound of broadband wave + integer :: num_elements !< Number of elements in the acoustic array + integer :: element_on !< Element in the acoustic array to turn on + integer :: bb_num_freq !< Number of frequencies in the broadband wave end type acoustic_parameters !> Acoustic source source_spatial pre-calculated values type source_spatial_type - integer, pointer, dimension(:,:) :: coord => null() !< List of grid points indices with non-zero source_spatial values - real(wp), pointer, dimension(:) :: val => null() !< List of non-zero source_spatial values - real(wp), pointer, dimension(:) :: angle => null() !< List of angles with x-axis for mom source term vector - real(wp), pointer, dimension(:,:) :: xyz_to_r_ratios => null() !< List of [xyz]/r for mom source term vector + integer, pointer, dimension(:,:) :: coord => null() !< List of grid points indices with non-zero source_spatial values + real(wp), pointer, dimension(:) :: val => null() !< List of non-zero source_spatial values + real(wp), pointer, dimension(:) :: angle => null() !< List of angles with x-axis for mom source term vector + real(wp), pointer, dimension(:,:) :: xyz_to_r_ratios => null() !< List of [xyz]/r for mom source term vector end type source_spatial_type !> Ghost Point for Immersed Boundaries type ghost_point - integer, dimension(3) :: loc !< Physical location of the ghost point - real(wp), dimension(3) :: ip_loc !< Physical location of the image point - integer, dimension(3) :: ip_grid !< Top left grid point of IP - real(wp), dimension(2, 2, 2) :: interp_coeffs !< Interpolation Coefficients of image point - integer :: ib_patch_id !< ID of the IB Patch the ghost point is part of + integer, dimension(3) :: loc !< Physical location of the ghost point + real(wp), dimension(3) :: ip_loc !< Physical location of the image point + integer, dimension(3) :: ip_grid !< Top left grid point of IP + real(wp), dimension(2, 2, 2) :: interp_coeffs !< Interpolation Coefficients of image point + integer :: ib_patch_id !< ID of the IB Patch the ghost point is part of real(wp) :: levelset real(wp), dimension(1:3) :: levelset_norm logical :: slip @@ -391,12 +391,12 @@ module m_derived_types !> Species parameters type species_parameters - character(LEN=name_len) :: name !< Name of species + character(LEN=name_len) :: name !< Name of species end type species_parameters !> Chemistry parameters type chemistry_parameters - character(LEN=name_len) :: cantera_file !< Path to Cantera file + character(LEN=name_len) :: cantera_file !< Path to Cantera file logical :: diffusion logical :: reactions @@ -410,18 +410,18 @@ module m_derived_types !> Lagrangian bubble parameters type bubbles_lagrange_parameters - integer :: solver_approach !< 1: One-way coupling, 2: two-way coupling - integer :: cluster_type !< Cluster model to find p_inf - logical :: pressure_corrector !< Cell pressure correction term - integer :: smooth_type !< Smoothing function. 1: Gaussian, 2:Delta 3x3 - logical :: heatTransfer_model !< Activate HEAT transfer model at the bubble-liquid interface - logical :: massTransfer_model !< Activate MASS transfer model at the bubble-liquid interface - logical :: write_bubbles !< Write files to track the bubble evolution each time step - logical :: write_bubbles_stats !< Write the maximum and minimum radius of each bubble - integer :: nBubs_glb !< Global number of bubbles - real(wp) :: epsilonb !< Standard deviation scaling for the gaussian function - real(wp) :: charwidth !< Domain virtual depth (z direction, for 2D simulations) - real(wp) :: valmaxvoid !< Maximum void fraction permitted + integer :: solver_approach !< 1: One-way coupling, 2: two-way coupling + integer :: cluster_type !< Cluster model to find p_inf + logical :: pressure_corrector !< Cell pressure correction term + integer :: smooth_type !< Smoothing function. 1: Gaussian, 2:Delta 3x3 + logical :: heatTransfer_model !< Activate HEAT transfer model at the bubble-liquid interface + logical :: massTransfer_model !< Activate MASS transfer model at the bubble-liquid interface + logical :: write_bubbles !< Write files to track the bubble evolution each time step + logical :: write_bubbles_stats !< Write the maximum and minimum radius of each bubble + integer :: nBubs_glb !< Global number of bubbles + real(wp) :: epsilonb !< Standard deviation scaling for the gaussian function + real(wp) :: charwidth !< Domain virtual depth (z direction, for 2D simulations) + real(wp) :: valmaxvoid !< Maximum void fraction permitted end type bubbles_lagrange_parameters !> Max and min number of cells in a direction of each combination of x-,y-, and z- diff --git a/src/common/m_finite_differences.fpp b/src/common/m_finite_differences.fpp index 4f979ce2e3..9724f3ecdd 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -18,7 +18,7 @@ contains type(scalar_field), intent(inout) :: div type(scalar_field), intent(in) :: fields(1:3) type(int_bounds_info), intent(in) :: ix_s, iy_s, iz_s - integer :: x, y, z !< Generic loop iterators + integer :: x, y, z !< Generic loop iterators real(wp) :: divergence $:GPU_PARALLEL_LOOP(collapse=3, private='[x, y, z, divergence]') @@ -82,13 +82,13 @@ contains !! @param offset_s Optional offset bounds in the s-coordinate direction subroutine s_compute_finite_difference_coefficients(q, s_cc, fd_coeff_s, local_buff_size, fd_number_in, fd_order_in, offset_s) - integer :: lB, lE !< loop bounds + integer :: lB, lE !< loop bounds integer, intent(in) :: q integer, intent(in) :: local_buff_size, fd_number_in, fd_order_in type(int_bounds_info), optional, intent(in) :: offset_s real(wp), allocatable, dimension(:,:), intent(inout) :: fd_coeff_s real(wp), dimension(-local_buff_size:q + local_buff_size), intent(in) :: s_cc - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator if (present(offset_s)) then lB = -offset_s%beg diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index 1ebf8537a2..f0eb1b0dcb 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -10,10 +10,10 @@ module m_helper use m_derived_types use m_global_parameters - use ieee_arithmetic !< For checking NaN + use ieee_arithmetic !< For checking NaN implicit none - private; + private public :: s_comp_n_from_prim, s_comp_n_from_cons, s_initialize_bubbles_model, s_initialize_nonpoly, s_simpson, s_transcoeff, & & s_int_to_str, s_transform_vec, s_transform_triangle, s_transform_model, s_swap, f_cross, f_create_transform_matrix, & & f_create_bbox, s_print_2D_array, f_xor, f_logical_to_int, associated_legendre, real_ylm, double_factorial, factorial, & @@ -119,7 +119,7 @@ contains impure subroutine s_initialize_bubble_vars() R0ref = bub_pp%R0ref; p0ref = bub_pp%p0ref - rho0ref = bub_pp%rho0ref; + rho0ref = bub_pp%rho0ref ss = bub_pp%ss; pv = bub_pp%pv; vd = bub_pp%vd mu_l = bub_pp%mu_l; mu_v = bub_pp%mu_v; mu_g = bub_pp%mu_g gam_v = bub_pp%gam_v; gam_g = bub_pp%gam_g @@ -173,7 +173,7 @@ contains integer :: ir real(wp), dimension(nb) :: chi_vw0, cp_m0, k_m0, rho_m0, x_vw, omegaN, rhol0 - real(wp), parameter :: k_poly = 1._wp !< polytropic index used to compute isothermal natural frequency + real(wp), parameter :: k_poly = 1._wp !< polytropic index used to compute isothermal natural frequency ! Chapman-Enskog transport coefficients for vapor-gas mixture, Ando JAS (2010) phi_vg = (1._wp + sqrt(mu_v/mu_g)*(M_g/M_v)**(0.25_wp))**2/(sqrt(8._wp)*sqrt(1._wp + M_v/M_g)) @@ -231,8 +231,8 @@ contains c1 = imag*omega*peclet c2 = sqrt(c1) - c3 = (exp(c2) - exp(-c2))/(exp(c2) + exp(-c2)) ! TANH(c2) - trans = ((c2/c3 - 1._wp)**(-1) - 3._wp/c1)**(-1) ! transfer function + c3 = (exp(c2) - exp(-c2))/(exp(c2) + exp(-c2)) ! TANH(c2) + trans = ((c2/c3 - 1._wp)**(-1) - 3._wp/c1)**(-1) ! transfer function Re_trans = trans Im_trans = aimag(trans) @@ -539,7 +539,7 @@ contains elemental function double_factorial(n_in) result(R_result) integer, intent(in) :: n_in - integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer + integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer integer(kind=int64_kind) :: R_result integer :: i @@ -553,7 +553,7 @@ contains elemental function factorial(n_in) result(R_result) integer, intent(in) :: n_in - integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer + integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer integer(kind=int64_kind) :: R_result integer :: i diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index deff316401..e0055275e1 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -10,7 +10,7 @@ module m_helper_basic use m_derived_types implicit none - private; + private public :: f_approx_equal, f_approx_in_array, f_is_default, f_all_default, f_is_integer, s_configure_coordinate_bounds, & & s_update_cell_bounds diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index fad7554512..785b075f26 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -609,7 +609,7 @@ contains & *r3(1)) denominator = r1_mag*r2_mag*r3_mag + dot_product(r1, r2)*r3_mag + dot_product(r2, r3)*r1_mag + dot_product(r3, & - & r1)*r2_mag + & r1)*r2_mag fraction = fraction + atan2(numerator, denominator) end do @@ -668,15 +668,15 @@ contains subroutine s_check_boundary(model, boundary_v, boundary_vertex_count, boundary_edge_count) type(t_model), intent(in) :: model - real(wp), allocatable, intent(out), dimension(:,:,:) :: boundary_v !< Output boundary vertices/normals - integer, intent(out) :: boundary_vertex_count, boundary_edge_count !< Output boundary vertex/edge count - integer :: i, j !< Model index iterator - integer :: edge_count, edge_index, store_index !< Boundary edge index iterator - real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer - real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer - real(wp), dimension(1:(3*model%ntrs), 1:2, 1:2) :: temp_boundary_v !< Temporary boundary vertex buffer - integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges - real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges + real(wp), allocatable, intent(out), dimension(:,:,:) :: boundary_v !< Output boundary vertices/normals + integer, intent(out) :: boundary_vertex_count, boundary_edge_count !< Output boundary vertex/edge count + integer :: i, j !< Model index iterator + integer :: edge_count, edge_index, store_index !< Boundary edge index iterator + real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer + real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer + real(wp), dimension(1:(3*model%ntrs), 1:2, 1:2) :: temp_boundary_v !< Temporary boundary vertex buffer + integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges + real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges ! Total number of edges in 2D STL edge_count = 3*model%ntrs @@ -779,10 +779,10 @@ contains !> This procedure appends the edge end vertices to a temporary buffer. subroutine s_register_edge(temp_boundary_v, edge, edge_index, edge_count) - integer, intent(inout) :: edge_index !< Edge index iterator - integer, intent(inout) :: edge_count !< Total number of edges - real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered - real(wp), dimension(1:edge_count, 1:2, 1:2), intent(inout) :: temp_boundary_v !< Temporary edge end vertex buffer + integer, intent(inout) :: edge_index !< Edge index iterator + integer, intent(inout) :: edge_count !< Total number of edges + real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered + real(wp), dimension(1:edge_count, 1:2, 1:2), intent(inout) :: temp_boundary_v !< Temporary edge end vertex buffer ! Increment edge index and store the edge edge_index = edge_index + 1 @@ -835,7 +835,7 @@ contains ! Project point onto triangle plane pv(:) = point(:) - v1(:) d = dot_product(pv, n) - if (abs(d) >= dist_min) cycle ! minimum distance is not small enough, no need to check validity + if (abs(d) >= dist_min) cycle ! minimum distance is not small enough, no need to check validity proj(:) = point(:) - d*n(:) ! Check if projection is inside triangle using barycentric coordinates @@ -980,12 +980,12 @@ contains dist = sqrt((point(1) - proj(1))**2 + (point(2) - proj(2))**2) norm(1) = gpu_boundary_v(i, 3, 1, pid) norm(2) = gpu_boundary_v(i, 3, 2, pid) - else if (t < 0._wp) then ! negative t means that v1 is the closest point on the edge + else if (t < 0._wp) then ! negative t means that v1 is the closest point on the edge dist = sqrt((point(1) - v1(1))**2 + (point(2) - v1(2))**2) norm(1) = v1(1) - point(1) norm(2) = v1(2) - point(2) norm = norm/dist - else ! t > 1 means that v2 is the closest point on the line edge + else ! t > 1 means that v2 is the closest point on the line edge dist = sqrt((point(1) - v2(1))**2 + (point(2) - v2(2))**2) norm(1) = v2(1) - point(1) norm(2) = v2(2) - point(2) @@ -1007,11 +1007,11 @@ contains subroutine s_instantiate_STL_models() ! Variables for IBM+STL - real(wp) :: normals(1:3) !< Boundary normal buffer - integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex - real(wp), allocatable, dimension(:,:,:) :: boundary_v !< Boundary vertex buffer - real(wp) :: dx_local, dy_local, dz_local !< Levelset distance buffer - integer :: i, j, k !< Generic loop iterators + real(wp) :: normals(1:3) !< Boundary normal buffer + integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex + real(wp), allocatable, dimension(:,:,:) :: boundary_v !< Boundary vertex buffer + real(wp) :: dx_local, dy_local, dz_local !< Levelset distance buffer + integer :: i, j, k !< Generic loop iterators integer :: patch_id type(t_bbox) :: bbox, bbox_old type(t_model) :: model diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 4dea1b31b7..b91410f313 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -9,7 +9,7 @@ module m_mpi_common #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_derived_types @@ -82,7 +82,7 @@ contains impure subroutine s_mpi_initialize #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_INIT(ierr) @@ -114,7 +114,7 @@ contains #ifdef MFC_MPI integer :: i, j - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors integer :: alt_sys if (present(beta)) then @@ -234,12 +234,12 @@ contains !> @brief Gathers variable-length real vectors from all MPI ranks onto the root process. impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root) - integer, intent(in) :: counts ! Array of vector lengths for each process - real(wp), intent(in), dimension(counts) :: my_vector ! Input vector on each process - integer, intent(in) :: root ! Rank of the root process - real(wp), allocatable, intent(out) :: gathered_vector(:) ! Gathered vector on the root process + integer, intent(in) :: counts ! Array of vector lengths for each process + real(wp), intent(in), dimension(counts) :: my_vector ! Input vector on each process + integer, intent(in) :: root ! Rank of the root process + real(wp), allocatable, intent(out) :: gathered_vector(:) ! Gathered vector on the root process integer :: i - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors integer, allocatable :: recounts(:), displs(:) #ifdef MFC_MPI @@ -268,7 +268,7 @@ contains real(wp), intent(inout) :: time_avg #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_GATHER(time_avg, 1, mpi_p, proc_time(0), 1, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif @@ -314,7 +314,7 @@ contains #ifdef MFC_SIMULATION #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_REDUCE(icfl_max_loc, icfl_max_glb, 1, mpi_p, MPI_MAX, 0, MPI_COMM_WORLD, ierr) @@ -345,7 +345,7 @@ contains real(wp), intent(out) :: var_glb #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) #endif @@ -361,7 +361,7 @@ contains real(wp), dimension(:,:), intent(out) :: var_glb #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors if (loc(var_loc) == loc(var_glb)) then call MPI_Allreduce(MPI_IN_PLACE, var_glb, num_vectors*vector_length, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -385,7 +385,7 @@ contains integer, intent(out) :: var_glb #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_ALLREDUCE(var_loc, var_glb, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr) #else @@ -405,7 +405,7 @@ contains real(wp), intent(out) :: var_glb #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, MPI_COMM_WORLD, ierr) #endif @@ -423,7 +423,7 @@ contains real(wp), intent(out) :: var_glb #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_ALLREDUCE(var_loc, var_glb, 1, mpi_p, MPI_MAX, MPI_COMM_WORLD, ierr) #endif @@ -439,7 +439,7 @@ contains real(wp), intent(inout) :: var_loc #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors real(wp) :: var_glb call MPI_REDUCE(var_loc, var_glb, 1, mpi_p, MPI_MIN, 0, MPI_COMM_WORLD, ierr) @@ -462,7 +462,7 @@ contains real(wp), dimension(2), intent(inout) :: var_loc #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors !> Temporary storage variable that holds the reduced maximum value and the rank of the processor with which the value is !! associated real(wp), dimension(2) :: var_glb @@ -484,7 +484,7 @@ contains integer, intent(in), optional :: code #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors #endif if (present(prnt)) then @@ -512,7 +512,7 @@ contains impure subroutine s_mpi_barrier #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_BARRIER(MPI_COMM_WORLD, ierr) #endif @@ -523,7 +523,7 @@ contains impure subroutine s_mpi_finalize #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_FINALIZE(ierr) #endif @@ -543,7 +543,7 @@ contains type(scalar_field), dimension(1:), intent(inout) :: q_comm real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in integer, intent(in) :: mpi_dir, pbc_loc, nVar - integer :: i, j, k, l, r, q !< Generic loop iterators + integer :: i, j, k, l, r, q !< Generic loop iterators integer :: buffer_counts(1:3), buffer_count type(int_bounds_info) :: boundary_conditions(1:3) integer :: beg_end(1:2), grid_dims(1:3) @@ -552,7 +552,7 @@ contains integer :: pack_offset, unpack_offset #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call nvtxStartRange("RHS-COMM-PACKBUF") @@ -744,7 +744,7 @@ contains #:endif end if #:endfor - call nvtxEndRange ! Packbuf + call nvtxEndRange ! Packbuf ! Send/Recv #ifdef MFC_SIMULATION @@ -757,7 +757,7 @@ contains call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, & & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA + call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA #:endcall GPU_HOST_DATA $:GPU_WAIT() #:else @@ -769,7 +769,7 @@ contains call MPI_SENDRECV(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, & & src_proc, recv_tag, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA + call nvtxEndRange ! RHS-MPI-SENDRECV-(NO)-RDMA call nvtxStartRange("RHS-COMM-HOST2DEV") $:GPU_UPDATE(device='[buff_recv]') @@ -958,17 +958,17 @@ contains subroutine s_mpi_decompose_computational_domain #ifdef MFC_MPI - integer :: num_procs_x, num_procs_y, num_procs_z !< Optimal number of processors in the x-, y- and z-directions + integer :: num_procs_x, num_procs_y, num_procs_z !< Optimal number of processors in the x-, y- and z-directions !> Non-optimal number of processors in the x-, y- and z-directions real(wp) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z - real(wp) :: fct_min !< Processor factorization (fct) minimization parameter - integer :: MPI_COMM_CART !< Cartesian processor topology communicator + real(wp) :: fct_min !< Processor factorization (fct) minimization parameter + integer :: MPI_COMM_CART !< Cartesian processor topology communicator !> Remaining number of cells, in a particular coordinate direction, after the majority is divided up among the available !! processors integer :: rem_cells - integer :: recon_order !< WENO or MUSCL reconstruction order - integer :: i, j !< Generic loop iterators - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: recon_order !< WENO or MUSCL reconstruction order + integer :: i, j !< Generic loop iterators + integer :: ierr !< Generic flag used to identify and report MPI errors if (recon_type == WENO_TYPE) then recon_order = weno_order @@ -1380,61 +1380,61 @@ contains integer, intent(in) :: pbc_loc #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors if (mpi_dir == 1) then - if (pbc_loc == -1) then ! PBC at the beginning + if (pbc_loc == -1) then ! PBC at the beginning - if (bc_x%end >= 0) then ! PBC at the beginning and end + if (bc_x%end >= 0) then ! PBC at the beginning and end call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(-buff_size), buff_size, mpi_p, & & bc_x%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else ! PBC at the beginning only + else ! PBC at the beginning only call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(-buff_size), buff_size, mpi_p, bc_x%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if - else ! PBC at the end - if (bc_x%beg >= 0) then ! PBC at the end and beginning + else ! PBC at the end + if (bc_x%beg >= 0) then ! PBC at the end and beginning call MPI_SENDRECV(dx(0), buff_size, mpi_p, bc_x%beg, 1, dx(m + 1), buff_size, mpi_p, bc_x%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else ! PBC at the end only + else ! PBC at the end only call MPI_SENDRECV(dx(m - buff_size + 1), buff_size, mpi_p, bc_x%end, 0, dx(m + 1), buff_size, mpi_p, & & bc_x%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if else if (mpi_dir == 2) then - if (pbc_loc == -1) then ! PBC at the beginning + if (pbc_loc == -1) then ! PBC at the beginning - if (bc_y%end >= 0) then ! PBC at the beginning and end + if (bc_y%end >= 0) then ! PBC at the beginning and end call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(-buff_size), buff_size, mpi_p, & & bc_y%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else ! PBC at the beginning only + else ! PBC at the beginning only call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(-buff_size), buff_size, mpi_p, bc_y%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if - else ! PBC at the end - if (bc_y%beg >= 0) then ! PBC at the end and beginning + else ! PBC at the end + if (bc_y%beg >= 0) then ! PBC at the end and beginning call MPI_SENDRECV(dy(0), buff_size, mpi_p, bc_y%beg, 1, dy(n + 1), buff_size, mpi_p, bc_y%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else ! PBC at the end only + else ! PBC at the end only call MPI_SENDRECV(dy(n - buff_size + 1), buff_size, mpi_p, bc_y%end, 0, dy(n + 1), buff_size, mpi_p, & & bc_y%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if end if else - if (pbc_loc == -1) then ! PBC at the beginning + if (pbc_loc == -1) then ! PBC at the beginning - if (bc_z%end >= 0) then ! PBC at the beginning and end + if (bc_z%end >= 0) then ! PBC at the beginning and end call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(-buff_size), buff_size, mpi_p, & & bc_z%beg, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else ! PBC at the beginning only + else ! PBC at the beginning only call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(-buff_size), buff_size, mpi_p, bc_z%beg, 0, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if - else ! PBC at the end - if (bc_z%beg >= 0) then ! PBC at the end and beginning + else ! PBC at the end + if (bc_z%beg >= 0) then ! PBC at the end and beginning call MPI_SENDRECV(dz(0), buff_size, mpi_p, bc_z%beg, 1, dz(p + 1), buff_size, mpi_p, bc_z%end, 1, & & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) - else ! PBC at the end only + else ! PBC at the end only call MPI_SENDRECV(dz(p - buff_size + 1), buff_size, mpi_p, bc_z%end, 0, dz(p + 1), buff_size, mpi_p, & & bc_z%end, 1, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) end if diff --git a/src/common/m_nvtx.f90 b/src/common/m_nvtx.f90 index 203d3389af..ebd7791977 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -16,15 +16,15 @@ module m_nvtx type, bind(C) :: nvtxEventAttributes integer(c_int16_t) :: version = 1 - integer(c_int16_t) :: size = 48 ! + integer(c_int16_t) :: size = 48 ! integer(c_int) :: category = 0 - integer(c_int) :: colorType = 1 ! NVTX_COLOR_ARGB = 1 + integer(c_int) :: colorType = 1 ! NVTX_COLOR_ARGB = 1 integer(c_int) :: color - integer(c_int) :: payloadType = 0 ! NVTX_PAYLOAD_UNKNOWN = 0 + integer(c_int) :: payloadType = 0 ! NVTX_PAYLOAD_UNKNOWN = 0 integer(c_int) :: reserved0 - integer(c_int64_t) :: payload ! union uint,int,double - integer(c_int) :: messageType = 1 ! NVTX_MESSAGE_TYPE_ASCII = 1 - type(c_ptr) :: message ! ascii char + integer(c_int64_t) :: payload ! union uint,int,double + integer(c_int) :: messageType = 1 ! NVTX_MESSAGE_TYPE_ASCII = 1 + type(c_ptr) :: message ! ascii char end type nvtxEventAttributes #if defined(MFC_GPU) && defined(__PGI) diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index c2ce84c865..dbb5a9af19 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -17,17 +17,17 @@ module m_phase_change use m_helper_basic implicit none - private; + private public :: s_initialize_phasechange_module, s_relaxation_solver, s_infinite_relaxation_k, s_finalize_relaxation_solver_module !> @name Parameters for the first order transition phase change !> @{ - integer, parameter :: max_iter = 1e8_wp !< max # of iterations - real(wp), parameter :: pCr = 4.94e7_wp ! Critical pressure of water [Pa] - real(wp), parameter :: TCr = 385.05_wp + 273.15_wp ! Critical temperature of water [K] - real(wp), parameter :: mixM = 1.0e-8_wp ! Mixture mass fraction threshold for triggering phase change - integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid - integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid + integer, parameter :: max_iter = 1e8_wp !< max # of iterations + real(wp), parameter :: pCr = 4.94e7_wp ! Critical pressure of water [Pa] + real(wp), parameter :: TCr = 385.05_wp + 273.15_wp ! Critical temperature of water [K] + real(wp), parameter :: mixM = 1.0e-8_wp ! Mixture mass fraction threshold for triggering phase change + integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid + integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid !> @} !> @name Gibbs free energy phase change parameters @@ -71,13 +71,13 @@ contains subroutine s_infinite_relaxation_k(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid + real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid !> equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor !! and subcooled liquid real(wp) :: TS, TSOV, TSSL, TSatOV, TSatSL - real(wp) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy - real(wp) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses - real(wp) :: TvF !< total volume fraction + real(wp) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy + real(wp) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses + real(wp) :: TvF !< total volume fraction ! $:GPU_DECLARE(create='[pS,pSOV,pSSL,TS,TSOV,TSSL,TSatOV,TSatSL]') ! $:GPU_DECLARE(create='[rhoe,dynE,rhos,rho,rM,m1,m2,MCT,TvF]') @@ -275,9 +275,9 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf real(wp), intent(in) :: rhoe real(wp), intent(out) :: TS - real(wp) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver + real(wp) :: gp, gpp, hp, pO, mCP, mQ !< variables for the Newton Solver real(wp) :: p_infpT_sum - integer :: i, ns !< generic loop iterators + integer :: i, ns !< generic loop iterators ! auxiliary variables for the pT-equilibrium solver mCP = 0.0_wp; mQ = 0.0_wp; p_infpT_sum = 0._wp $:GPU_LOOP(parallelism='[seq]') @@ -377,14 +377,14 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf real(wp), intent(inout) :: TS #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium + real(wp), dimension(3) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium #:else - real(wp), dimension(num_fluids) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium + real(wp), dimension(num_fluids) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium #:endif - real(wp), dimension(2, 2) :: Jac, InvJac, TJac !< matrices for the Newton Solver - real(wp), dimension(2) :: R2D, DeltamP !< residual and correction array - real(wp) :: Om ! underrelaxation factor - real(wp) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver + real(wp), dimension(2, 2) :: Jac, InvJac, TJac !< matrices for the Newton Solver + real(wp), dimension(2) :: R2D, DeltamP !< residual and correction array + real(wp) :: Om ! underrelaxation factor + real(wp) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver real(wp) :: ml, mT, dFdT, dTdm, dTdp !> Generic loop iterators @@ -592,7 +592,7 @@ contains real(wp), intent(in) :: pSat real(wp), intent(out) :: TSat real(wp), intent(in) :: TSIn - real(wp) :: dFdT, FT, Om !< auxiliary variables + real(wp) :: dFdT, FT, Om !< auxiliary variables ! Generic loop iterators integer :: ns diff --git a/src/common/m_precision_select.f90 b/src/common/m_precision_select.f90 index 414dbf1940..5fc1c5c667 100644 --- a/src/common/m_precision_select.f90 +++ b/src/common/m_precision_select.f90 @@ -7,13 +7,13 @@ module m_precision_select ! use, intrinsic :: iso_c_binding #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif implicit none ! Define the available precision types - integer, parameter :: half_precision = 2 ! selected_real_kind(3, 4) + integer, parameter :: half_precision = 2 ! selected_real_kind(3, 4) integer, parameter :: single_precision = selected_real_kind(6, 37) integer, parameter :: double_precision = selected_real_kind(15, 307) integer, parameter :: hp = half_precision @@ -22,7 +22,7 @@ module m_precision_select ! Set the working precision (wp) to single or double #ifdef MFC_SINGLE_PRECISION - integer, parameter :: wp = single_precision ! Change to single_precision if needed + integer, parameter :: wp = single_precision ! Change to single_precision if needed #else integer, parameter :: wp = double_precision #endif @@ -42,7 +42,7 @@ module m_precision_select ! MPI types per element. IE Real(kind=2) <=> 2 MPI_BYTE integer, parameter :: mpi_io_type = merge(2, 1, stp == half_precision) #else - integer, parameter :: mpi_p = -100 ! Default value when MPI is not used + integer, parameter :: mpi_p = -100 ! Default value when MPI is not used integer, parameter :: mpi_2p = -100 integer, parameter :: mpi_io_p = -100 integer, parameter :: mpi_io_type = -100 diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 3943977633..50753735af 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -18,7 +18,7 @@ module m_variables_conversion implicit none - private; + private public :: s_initialize_variables_conversion_module, & s_initialize_pb, & s_initialize_mv, & @@ -51,10 +51,10 @@ module m_variables_conversion integer :: is1b, is2b, is3b, is1e, is2e, is3e $:GPU_DECLARE(create='[is1b, is2b, is3b, is1e, is2e, is3e]') - real(wp), allocatable, dimension(:,:,:), public :: rho_sf !< Scalar density function - real(wp), allocatable, dimension(:,:,:), public :: gamma_sf !< Scalar sp. heat ratio function - real(wp), allocatable, dimension(:,:,:), public :: pi_inf_sf !< Scalar liquid stiffness function - real(wp), allocatable, dimension(:,:,:), public :: qv_sf !< Scalar liquid energy reference function + real(wp), allocatable, dimension(:,:,:), public :: rho_sf !< Scalar density function + real(wp), allocatable, dimension(:,:,:), public :: gamma_sf !< Scalar sp. heat ratio function + real(wp), allocatable, dimension(:,:,:), public :: pi_inf_sf !< Scalar liquid stiffness function + real(wp), allocatable, dimension(:,:,:), public :: qv_sf !< Scalar liquid energy reference function contains @@ -80,9 +80,9 @@ contains real(wp), optional, intent(out) :: G_K real(wp), optional, dimension(num_fluids), intent(in) :: G - if (model_eqns == 1) then ! Gamma/pi_inf model + if (model_eqns == 1) then ! Gamma/pi_inf model call s_convert_mixture_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv) - else ! Volume fraction model + else ! Volume fraction model call s_convert_species_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv, Re_K, G_K, G) end if @@ -121,7 +121,7 @@ contains real(wp) :: E_e real(wp) :: e_Per_Kg, Pdyn_Per_Kg real(wp) :: T_guess - integer :: s !< Generic loop iterator + integer :: s !< Generic loop iterator #:if not chemistry ! Depending on model_eqns and bubbles_euler, the appropriate procedure for computing pressure is targeted by the ! procedure pointer @@ -193,7 +193,7 @@ contains rho = q_vf(1)%sf(i, j, k) gamma = q_vf(gamma_idx)%sf(i, j, k) pi_inf = q_vf(pi_inf_idx)%sf(i, j, k) - qv = 0._wp ! keep this value nil for now. For future adjustment + qv = 0._wp ! keep this value nil for now. For future adjustment ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated #ifdef MFC_POST_PROCESS @@ -231,7 +231,7 @@ contains real(wp), optional, intent(out) :: G_K real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K real(wp), optional, dimension(num_fluids), intent(in) :: G - integer :: i, j !< Generic loop iterator + integer :: i, j !< Generic loop iterator ! Computing the density, the specific heat ratio function and the liquid stiffness function, respectively call s_compute_species_fraction(q_vf, k, l, r, alpha_rho_K, alpha_K) @@ -303,7 +303,7 @@ contains real(wp), dimension(2), intent(out) :: Re_K real(wp), optional, intent(out) :: G_K real(wp) :: alpha_K_sum - integer :: i, j !< Generic loop iterators + integer :: i, j !< Generic loop iterators #ifdef MFC_SIMULATION ! Constrain partial densities and volume fractions within physical bounds if (num_fluids == 1 .and. bubbles_euler) then @@ -333,7 +333,7 @@ contains if (present(G_K)) then G_K = 0._wp do i = 1, num_fluids - ! TODO: change to use Gs_vc directly here? TODO: Make this changes as well for GPUs + ! TODO: change to use Gs_vc directly here? TODO: Make this change as well for GPUs G_K = G_K + alpha_K(i)*G(i) end do G_K = max(0._wp, G_K) @@ -528,18 +528,18 @@ contains real(wp) :: vftmp, nbub_sc real(wp) :: G_K real(wp) :: pres - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators real(wp) :: T real(wp) :: pres_mag - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: B2 ! Magnetic field magnitude squared - real(wp) :: B(3) ! Magnetic field components - real(wp) :: m2 ! Relativistic momentum magnitude squared - real(wp) :: S ! Dot product of the magnetic field and the relativistic momentum - real(wp) :: W, dW ! W := rho*v*Ga**2; f = f(W) in Newton-Raphson - real(wp) :: E, D ! Prim/Cons variables within Newton-Raphson iteration - real(wp) :: f, dGa_dW, dp_dW, df_dW ! Functions within Newton-Raphson iteration - integer :: iter ! Newton-Raphson iteration counter + real(wp) :: Ga ! Lorentz factor (gamma in relativity) + real(wp) :: B2 ! Magnetic field magnitude squared + real(wp) :: B(3) ! Magnetic field components + real(wp) :: m2 ! Relativistic momentum magnitude squared + real(wp) :: S ! Dot product of the magnetic field and the relativistic momentum + real(wp) :: W, dW ! W := rho*v*Ga**2; f = f(W) in Newton-Raphson + real(wp) :: E, D ! Prim/Cons variables within Newton-Raphson iteration + real(wp) :: f, dGa_dW, dp_dW, df_dW ! Functions within Newton-Raphson iteration + integer :: iter ! Newton-Raphson iteration counter $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_K, alpha_rho_K, Re_K, nRtmp, rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K, & & rhoYks, B, pres, vftmp, nbub_sc, G_K, T, pres_mag, Ga, B2, m2, S, W, dW, E, D, f, dGa_dW, dp_dW, & @@ -556,10 +556,10 @@ contains ! If in simulation, use acc mixture subroutines if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K, G_K, Gs_vc) + & Re_K, G_K, Gs_vc) else call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K) + & Re_K) end if #else ! If pre-processing, use non acc mixture subroutines @@ -619,14 +619,14 @@ contains ! cancel with the 2* in other terms This corrected version is not used as the second equation ! empirically converges faster. First equation is kept for further investigation. dGa_dW = -Ga**3 * ( ! S**2*(3*W**2+3*W*B2+B2**2) + m2*W**2 ) / (W**3 * (W+B2)**3) ! first (corrected) - dGa_dW = -Ga**3*(2*S**2*(3*W**2 + 3*W*B2 + B2**2) + m2*W**2)/(2*W**3*(W + B2)**3) ! second (in paper) + dGa_dW = -Ga**3*(2*S**2*(3*W**2 + 3*W*B2 + B2**2) + m2*W**2)/(2*W**3*(W + B2)**3) ! second (in paper) dp_dW = (Ga*(1 + D*dGa_dW) - 2*W*dGa_dW)/((gamma_K + 1)*Ga**3) df_dW = 1 - dp_dW + (B2/Ga**3)*dGa_dW + S**2/W**3 dW = -f/df_dW W = W + dW - if (abs(dW) < 1.e-12_wp*W) exit ! Relative convergence criterion + if (abs(dW) < 1.e-12_wp*W) exit ! Relative convergence criterion end do ! Recalculate pressure using converged W @@ -638,14 +638,14 @@ contains do i = 1, 3 qK_prim_vf(momxb + i - 1)%sf(j, k, l) = (qK_cons_vf(momxb + i - 1)%sf(j, k, l) + (S/W)*B(i))/(W + B2) end do - qK_prim_vf(1)%sf(j, k, l) = D/Ga ! Hard-coded for single-component for now + qK_prim_vf(1)%sf(j, k, l) = D/Ga ! Hard-coded for single-component for now $:GPU_LOOP(parallelism='[seq]') do i = B_idx%beg, B_idx%end qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) end do - cycle ! skip all the non-relativistic conversions below + cycle ! skip all the non-relativistic conversions below end if if (chemistry) then @@ -837,16 +837,16 @@ contains real(wp), dimension(nb) :: Rtmp real(wp) :: G real(wp), dimension(2) :: Re_K - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators real(wp), dimension(num_species) :: Ys real(wp) :: e_mix, mix_mol_weight, T real(wp) :: pres_mag - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: h ! relativistic enthalpy - real(wp) :: v2 ! Square of the velocity magnitude - real(wp) :: B2 ! Square of the magnetic field magnitude - real(wp) :: vdotB ! Dot product of the velocity and magnetic field vectors - real(wp) :: B(3) ! Magnetic field components + real(wp) :: Ga ! Lorentz factor (gamma in relativity) + real(wp) :: h ! relativistic enthalpy + real(wp) :: v2 ! Square of the velocity magnitude + real(wp) :: B2 ! Square of the magnetic field magnitude + real(wp) :: vdotB ! Dot product of the velocity and magnetic field vectors + real(wp) :: B(3) ! Magnetic field components pres_mag = 0._wp @@ -886,7 +886,7 @@ contains Ga = 1._wp/sqrt(1._wp - v2) - h = 1._wp + (gamma + 1)*q_prim_vf(E_idx)%sf(j, k, l)/rho ! Assume perfect gas for now + h = 1._wp + (gamma + 1)*q_prim_vf(E_idx)%sf(j, k, l)/rho ! Assume perfect gas for now B2 = 0._wp do i = B_idx%beg, B_idx%end @@ -917,7 +917,7 @@ contains q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) end do - cycle ! skip all the non-relativistic conversions below + cycle ! skip all the non-relativistic conversions below end if ! Transferring the continuity equation(s) variable(s) @@ -1105,7 +1105,7 @@ contains real(wp), dimension(2) :: Re_K real(wp) :: G_K real(wp) :: T_K, mix_mol_weight, R_gas - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators is1b = is1%beg; is1e = is1%end is2b = is2%beg; is2e = is2%end @@ -1145,7 +1145,7 @@ contains pres_K = qK_prim_vf(j, k, l, E_idx) if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, & - & Re_K, G_K, Gs_vc) + & Re_K, G_K, Gs_vc) else call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K) end if @@ -1309,20 +1309,20 @@ contains real(wp) :: blkmod1, blkmod2 integer :: q - if (chemistry) then ! Reacting mixture sound speed + if (chemistry) then ! Reacting mixture sound speed if (avg_state == 1 .and. abs(c_c) > verysmall) then c = sqrt(c_c - (gamma - 1.0_wp)*(vel_sum - H)) else c = sqrt((1.0_wp + 1.0_wp/gamma)*pres/rho) end if - else if (relativity) then ! Relativistic sound speed + else if (relativity) then ! Relativistic sound speed c = sqrt((1._wp + 1._wp/gamma)*pres/rho/H) else - if (alt_soundspeed) then ! Wood's mixture sound speed via bulk moduli + if (alt_soundspeed) then ! Wood's mixture sound speed via bulk moduli blkmod1 = ((gammas(1) + 1._wp)*pres + pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1._wp)*pres + pi_infs(2))/gammas(2) c = (1._wp/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) - else if (model_eqns == 3) then ! Six-equation model sound speed + else if (model_eqns == 3) then ! Six-equation model sound speed c = 0._wp $:GPU_LOOP(parallelism='[seq]') do q = 1, num_fluids @@ -1358,7 +1358,7 @@ contains $:GPU_ROUTINE(function_name='s_compute_fast_magnetosonic_speed', parallelism='[seq]', cray_noinline=True) real(wp), intent(in) :: B(3), rho, c - real(wp), intent(in) :: h ! only used for relativity + real(wp), intent(in) :: h ! only used for relativity real(wp), intent(out) :: c_fast integer, intent(in) :: norm real(wp) :: B2, term, disc diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index fdce73ca18..9b1f61175e 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -35,11 +35,11 @@ impure subroutine s_read_abstract_data_files(t_step) end subroutine s_read_abstract_data_files end interface - type(scalar_field), allocatable, dimension(:), public :: q_cons_vf !< Conservative variables + type(scalar_field), allocatable, dimension(:), public :: q_cons_vf !< Conservative variables type(scalar_field), allocatable, dimension(:), public :: q_cons_temp - type(scalar_field), allocatable, dimension(:), public :: q_prim_vf !< Primitive variables - type(integer_field), allocatable, dimension(:,:), public :: bc_type !< Boundary condition identifiers - type(scalar_field), public :: q_T_sf !< Temperature field + type(scalar_field), allocatable, dimension(:), public :: q_prim_vf !< Primitive variables + type(integer_field), allocatable, dimension(:,:), public :: bc_type !< Boundary condition identifiers + type(scalar_field), public :: q_T_sf !< Temperature field ! type(scalar_field), public :: ib_markers !< type(integer_field), public :: ib_markers @@ -147,7 +147,7 @@ impure subroutine s_read_ib_data_files(file_loc_base, t_step) p_MOK = int(p_glb + 1, MPI_OFFSET_KIND) MOK = int(1._wp, MPI_OFFSET_KIND) WP_MOK = int(storage_size(0._stp)/8, MPI_OFFSET_KIND) - save_index = t_step/t_step_save ! get the number of saves done to this point + save_index = t_step/t_step_save ! get the number of saves done to this point data_size = (m + 1)*(n + 1)*(p + 1) var_MOK = int(sys_size + 1, MPI_OFFSET_KIND) diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 91ebee57df..918d2eda9b 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -210,7 +210,7 @@ contains end if end if - if (bubbles_lagrange) then ! Lagrangian solver + if (bubbles_lagrange) then ! Lagrangian solver if (lag_txt_wrt) then dbdir = trim(case_dir) // '/lag_bubbles_post_process' file_loc = trim(dbdir) // '/.' @@ -321,7 +321,7 @@ contains integer :: lower_bound, upper_bound #:for X, M in [('x', 'm'), ('y', 'n'), ('z', 'p')] - if (${M}$ == 0) return ! Early return for y or z if simulation is 1D or 2D + if (${M}$ == 0) return ! Early return for y or z if simulation is 1D or 2D lower_bound = -offset_${X}$%beg upper_bound = ${M}$ + offset_${X}$%end @@ -1171,7 +1171,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf integer :: i, j, k, l, cent - integer :: counter, root !< number of data points extracted to fit shape to SH perturbations + integer :: counter, root !< number of data points extracted to fit shape to SH perturbations real(wp), allocatable :: x_td(:), y_td(:), x_d1(:), y_d1(:), y_d(:), x_d(:) real(wp) :: axp, axm, ayp, aym, tgp, euc_d, thres, maxalph_loc, maxalph_glb @@ -1261,7 +1261,7 @@ contains real(wp) :: rho, pres, dV, tmp, gamma, pi_inf, MaxMa, MaxMa_glb, maxvel, c, Ma, H, qv real(wp), dimension(num_vels) :: vel real(wp), dimension(num_fluids) :: adv - integer :: i, j, k, l, s ! looping indices + integer :: i, j, k, l, s ! looping indices Egk = 0._wp Elp = 0._wp diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 9821957777..24a292df28 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -201,19 +201,19 @@ contains slope = (top*bottom)/(bottom**2._wp + 1.e-16_wp) end if - if (flux_lim == 1) then ! MINMOD (MM) + if (flux_lim == 1) then ! MINMOD (MM) q_sf(j, k, l) = max(0._wp, min(1._wp, slope)) - else if (flux_lim == 2) then ! MUSCL (MC) + else if (flux_lim == 2) then ! MUSCL (MC) q_sf(j, k, l) = max(0._wp, min(2._wp*slope, 5.e-1_wp*(1._wp + slope), 2._wp)) - else if (flux_lim == 3) then ! OSPRE (OP) + else if (flux_lim == 3) then ! OSPRE (OP) q_sf(j, k, l) = (15.e-1_wp*(slope**2._wp + slope))/(slope**2._wp + slope + 1._wp) - else if (flux_lim == 4) then ! SUPERBEE (SB) + else if (flux_lim == 4) then ! SUPERBEE (SB) q_sf(j, k, l) = max(0._wp, min(1._wp, 2._wp*slope), min(slope, 2._wp)) - else if (flux_lim == 5) then ! SWEBY (SW) (beta = 1.5) + else if (flux_lim == 5) then ! SWEBY (SW) (beta = 1.5) q_sf(j, k, l) = max(0._wp, min(15.e-1_wp*slope, 1._wp), min(slope, 15.e-1_wp)) - else if (flux_lim == 6) then ! VAN ALBADA (VA) + else if (flux_lim == 6) then ! VAN ALBADA (VA) q_sf(j, k, l) = (slope**2._wp + slope)/(slope**2._wp + 1._wp) - else if (flux_lim == 7) then ! VAN LEER (VL) + else if (flux_lim == 7) then ! VAN LEER (VL) q_sf(j, k, l) = (abs(slope) + slope)/(1._wp + abs(slope)) end if end do @@ -409,18 +409,18 @@ contains !> Liutex rigid rotation axis real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, nm), & & intent(out) :: liutex_axis - character, parameter :: ivl = 'N' !< compute left eigenvectors - character, parameter :: ivr = 'V' !< compute right eigenvectors - real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor - real(wp), dimension(nm) :: lr, li !< real and imaginary parts of eigenvalues - real(wp), dimension(nm, nm) :: vl, vr !< left and right eigenvectors - integer, parameter :: lwork = 4*nm !< size of work array (4*nm recommended) - real(wp), dimension(lwork) :: work !< work array + character, parameter :: ivl = 'N' !< compute left eigenvectors + character, parameter :: ivr = 'V' !< compute right eigenvectors + real(wp), dimension(nm, nm) :: vgt !< velocity gradient tensor + real(wp), dimension(nm) :: lr, li !< real and imaginary parts of eigenvalues + real(wp), dimension(nm, nm) :: vl, vr !< left and right eigenvectors + integer, parameter :: lwork = 4*nm !< size of work array (4*nm recommended) + real(wp), dimension(lwork) :: work !< work array integer :: info - real(wp), dimension(nm) :: eigvec !< real eigenvector - real(wp) :: eigvec_mag !< magnitude of real eigenvector - real(wp) :: omega_proj !< projection of vorticity on real eigenvector - real(wp) :: lci !< imaginary part of complex eigenvalue + real(wp), dimension(nm) :: eigvec !< real eigenvector + real(wp) :: eigvec_mag !< magnitude of real eigenvector + real(wp) :: omega_proj !< projection of vorticity on real eigenvector + real(wp) :: lci !< imaginary part of complex eigenvalue real(wp) :: alpha integer :: j, k, l, r, i integer :: idx @@ -509,7 +509,7 @@ contains real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - real(wp) :: drho_dx, drho_dy, drho_dz !< Spatial derivatives of the density in the x-, y- and z-directions + real(wp) :: drho_dx, drho_dy, drho_dz !< Spatial derivatives of the density in the x-, y- and z-directions !> Maximum value of the gradient magnitude (gm) of the density field in entire computational domain and not just the local !! sub-domain. The first position in the variable contains the maximum value and the second contains the rank of the !! processor on which it occurred. @@ -563,9 +563,9 @@ contains ! model, the amplitude of the exponential's inside is also modulated with respect to the identity of the fluid in which the ! function is evaluated. For more information, refer to Marquina and Mulet (2003). - if (model_eqns == 1) then ! Gamma/pi_inf model + if (model_eqns == 1) then ! Gamma/pi_inf model q_sf = -gm_rho_sf/gm_rho_max(1) - else ! Volume fraction model + else ! Volume fraction model do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index 2672cc214b..4aec00b595 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -8,7 +8,7 @@ module m_global_parameters #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_derived_types @@ -19,13 +19,13 @@ module m_global_parameters !> @name Logistics !> @{ - integer :: num_procs !< Number of processors - character(LEN=path_len) :: case_dir !< Case folder location + integer :: num_procs !< Number of processors + character(LEN=path_len) :: case_dir !< Case folder location !> @} ! Computational Domain Parameters - integer :: proc_rank !< Rank of the local processor + integer :: proc_rank !< Rank of the local processor !> @name Number of cells in the x-, y- and z-coordinate directions !> @{ integer :: m, m_root @@ -35,7 +35,7 @@ module m_global_parameters !> @name Max and min number of cells in a direction of each combination of x-,y-, and z- type(cell_num_bounds) :: cells_bounds - integer(kind=8) :: nGlobal ! Total number of cells in global domain + integer(kind=8) :: nGlobal ! Total number of cells in global domain !> @name Cylindrical coordinates (either axisymmetric or full 3D) !> @{ @@ -48,8 +48,8 @@ module m_global_parameters integer :: m_glb, n_glb, p_glb !> @} - integer :: num_dims !< Number of spatial dimensions - integer :: num_vels !< Number of velocity components (different from num_dims for mhd) + integer :: num_dims !< Number of spatial dimensions + integer :: num_vels !< Number of velocity components (different from num_dims for mhd) !> @name Cell-boundary locations in the x-, y- and z-coordinate directions !> @{ real(wp), allocatable, dimension(:) :: x_cb, x_root_cb, y_cb, z_cb @@ -69,9 +69,9 @@ module m_global_parameters !> Number of cells in buffer region. For the variables which feature a buffer region, this region is used to store information !! outside the computational domain based on the boundary conditions. integer :: buff_size - integer :: t_step_start !< First time-step directory - integer :: t_step_stop !< Last time-step directory - integer :: t_step_save !< Interval between consecutive time-step directory + integer :: t_step_start !< First time-step directory + integer :: t_step_stop !< Last time-step directory + integer :: t_step_save !< Interval between consecutive time-step directory !> @name IO options for adaptive time-stepping !> @{ logical :: cfl_adap_dt, cfl_const_dt, cfl_dt @@ -86,52 +86,52 @@ module m_global_parameters !> @name Simulation Algorithm Parameters !> @{ - integer :: model_eqns !< Multicomponent flow model - integer :: num_fluids !< Number of different fluids present in the flow - logical :: relax !< phase change - integer :: relax_model !< Phase change relaxation model - logical :: mpp_lim !< Maximum volume fraction limiter - integer :: sys_size !< Number of unknowns in the system of equations - integer :: recon_type !< Which type of reconstruction to use - integer :: weno_order !< Order of accuracy for the WENO reconstruction - integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction - logical :: mixture_err !< Mixture error limiter - logical :: alt_soundspeed !< Alternate sound speed - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity for RMHD - logical :: hypoelasticity !< Turn hypoelasticity on - logical :: hyperelasticity !< Turn hyperelasticity on - logical :: elasticity !< elasticity modeling, true for hyper or hypo - integer :: b_size !< Number of components in the b tensor - integer :: tensor_size !< Number of components in the nonsymmetric tensor - logical :: cont_damage !< Continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD - logical :: igr !< enable IGR - integer :: igr_order !< IGR reconstruction order - logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling + integer :: model_eqns !< Multicomponent flow model + integer :: num_fluids !< Number of different fluids present in the flow + logical :: relax !< phase change + integer :: relax_model !< Phase change relaxation model + logical :: mpp_lim !< Maximum volume fraction limiter + integer :: sys_size !< Number of unknowns in the system of equations + integer :: recon_type !< Which type of reconstruction to use + integer :: weno_order !< Order of accuracy for the WENO reconstruction + integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction + logical :: mixture_err !< Mixture error limiter + logical :: alt_soundspeed !< Alternate sound speed + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity for RMHD + logical :: hypoelasticity !< Turn hypoelasticity on + logical :: hyperelasticity !< Turn hyperelasticity on + logical :: elasticity !< elasticity modeling, true for hyper or hypo + integer :: b_size !< Number of components in the b tensor + integer :: tensor_size !< Number of components in the nonsymmetric tensor + logical :: cont_damage !< Continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD + logical :: igr !< enable IGR + integer :: igr_order !< IGR reconstruction order + logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling !> @} - integer :: avg_state !< Average state evaluation method + integer :: avg_state !< Average state evaluation method !> @name Annotations of the structure, i.e. the organization, of the state vectors !> @{ - type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. - type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of energy equation - integer :: n_idx !< Index of number density - integer :: beta_idx !< Index of lagrange bubbles beta - type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. - type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. - type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: alf_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. - type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. - type(int_bounds_info) :: stress_idx !< Indices of elastic stresses - type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: c_idx !< Index of color function - type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. + type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. + integer :: E_idx !< Index of energy equation + integer :: n_idx !< Index of number density + integer :: beta_idx !< Index of lagrange bubbles beta + type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. + type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. + type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: alf_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. + type(int_bounds_info) :: stress_idx !< Indices of elastic stresses + type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. + integer :: c_idx !< Index of color function + type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD !> @} ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). Stands for "InDices With BUFFer". @@ -147,17 +147,17 @@ module m_global_parameters !> @} integer :: shear_num !! Number of shear stress components - integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, !! [indices]) integer, dimension(3, 2) :: shear_BC_flip_indices - logical :: parallel_io !< Format of the data files + logical :: parallel_io !< Format of the data files logical :: sim_data - logical :: file_per_process !< output format - integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM - integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid - integer :: num_ibs !< Number of immersed boundaries + logical :: file_per_process !< output format + integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM + integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid + integer :: num_ibs !< Number of immersed boundaries #ifdef MFC_MPI type(mpi_io_var), public :: MPI_IO_DATA type(mpi_io_ib_var), public :: MPI_IO_IB_DATA @@ -177,15 +177,15 @@ module m_global_parameters type(physical_parameters), dimension(num_fluids_max) :: fluid_pp ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp - real(wp), allocatable, dimension(:) :: adv !< Advection variables + real(wp), allocatable, dimension(:) :: adv !< Advection variables ! Formatted Database File(s) Structure Parameters - integer :: format !< Format of the database file(s) - integer :: precision !< Floating point precision of the database file(s) - logical :: down_sample !< down sampling of the database file(s) - logical :: output_partial_domain !< Specify portion of domain to output for post-processing - type(bounds_info) :: x_output, y_output, z_output !< Portion of domain to output for post-processing - type(int_bounds_info) :: x_output_idx, y_output_idx, z_output_idx !< Indices of domain to output for post-processing + integer :: format !< Format of the database file(s) + integer :: precision !< Floating point precision of the database file(s) + logical :: down_sample !< down sampling of the database file(s) + logical :: output_partial_domain !< Specify portion of domain to output for post-processing + type(bounds_info) :: x_output, y_output, z_output !< Portion of domain to output for post-processing + type(int_bounds_info) :: x_output_idx, y_output_idx, z_output_idx !< Indices of domain to output for post-processing !> @name Size of the ghost zone layer in the x-, y- and z-coordinate directions. The definition of the ghost zone layers is only !! necessary when using the Silo database file format in multidimensions. These zones provide VisIt with the subdomain !! connectivity information that it requires in order to produce smooth plots. @@ -274,7 +274,7 @@ module m_global_parameters logical :: polytropic logical :: polydisperse logical :: adv_n - integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer + integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl real(wp) :: gam_m real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g @@ -309,8 +309,8 @@ module m_global_parameters logical :: bubbles_lagrange !> @} - real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) - real(wp) :: wall_time, wall_time_avg !< Wall time measurements + real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) + real(wp) :: wall_time, wall_time_avg !< Wall time measurements contains @@ -318,7 +318,7 @@ contains !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator ! Logistics case_dir = '.' @@ -406,8 +406,8 @@ contains bub_pp%gam_g = dflt_real; gam_g = dflt_real bub_pp%M_v = dflt_real; M_v = dflt_real bub_pp%M_g = dflt_real; M_g = dflt_real - bub_pp%k_v = dflt_real; - bub_pp%k_g = dflt_real; + bub_pp%k_v = dflt_real + bub_pp%k_g = dflt_real bub_pp%cp_v = dflt_real; cp_v = dflt_real bub_pp%cp_g = dflt_real; cp_g = dflt_real bub_pp%R_v = dflt_real; R_v = dflt_real @@ -551,7 +551,7 @@ contains ! Volume fractions are stored in the indices immediately following the energy equation. IGR tracks a total of (N-1) ! volume fractions for N fluids, hence the "-1" in adv_idx%end. If num_fluids = 1 then adv_idx%end < adv_idx%beg, ! which skips all loops over the volume fractions since there is no volume fraction to track - adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 + adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 adv_idx%end = E_idx + num_fluids - 1 else ! Volume fractions are stored in the indices immediately following the energy equation. WENO/MUSCL + Riemann tracks @@ -629,9 +629,9 @@ contains if (mhd) then B_idx%beg = sys_size + 1 if (n == 0) then - B_idx%end = sys_size + 2 ! 1D: By, Bz + B_idx%end = sys_size + 2 ! 1D: By, Bz else - B_idx%end = sys_size + 3 ! 2D/3D: Bx, By, Bz + B_idx%end = sys_size + 3 ! 2D/3D: Bx, By, Bz end if sys_size = B_idx%end end if @@ -650,17 +650,17 @@ contains internalEnergies_idx%beg = adv_idx%end + 1 internalEnergies_idx%end = adv_idx%end + num_fluids sys_size = internalEnergies_idx%end - alf_idx = 1 ! dummy, cannot actually have a void fraction + alf_idx = 1 ! dummy, cannot actually have a void fraction else if (model_eqns == 4) then - cont_idx%beg = 1 ! one continuity equation - cont_idx%end = 1 ! num_fluids - mom_idx%beg = cont_idx%end + 1 ! one momentum equation in each + cont_idx%beg = 1 ! one continuity equation + cont_idx%end = 1 ! num_fluids + mom_idx%beg = cont_idx%end + 1 ! one momentum equation in each mom_idx%end = cont_idx%end + num_vels - E_idx = mom_idx%end + 1 ! one energy equation + E_idx = mom_idx%end + 1 ! one energy equation adv_idx%beg = E_idx + 1 - adv_idx%end = adv_idx%beg ! one volume advection equation + adv_idx%end = adv_idx%beg ! one volume advection equation alf_idx = adv_idx%end - sys_size = alf_idx ! adv_idx%end + sys_size = alf_idx ! adv_idx%end if (bubbles_euler) then bub_idx%beg = sys_size + 1 @@ -900,11 +900,11 @@ contains allocate (adv(num_fluids)) - if (cyl_coord .neqv. .true.) then ! Cartesian grid + if (cyl_coord .neqv. .true.) then ! Cartesian grid grid_geometry = 1 - else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid + else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid grid_geometry = 2 - else ! Fully 3D cylindrical grid + else ! Fully 3D cylindrical grid grid_geometry = 3 end if @@ -914,7 +914,7 @@ contains impure subroutine s_initialize_parallel_io #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors #endif num_dims = 1 + min(1, n) + min(1, p) diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index 77d20fe562..3139fac772 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -6,7 +6,7 @@ module m_mpi_proxy #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_derived_types @@ -29,8 +29,8 @@ contains impure subroutine s_initialize_mpi_proxy_module #ifdef MFC_MPI - integer :: i !< Generic loop iterator - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: i !< Generic loop iterator + integer :: ierr !< Generic flag used to identify and report MPI errors ! Allocating and configuring the receive counts and the displacement vector variables used in variable-gather communication ! procedures. Note that these are only needed for either multidimensional runs that utilize the Silo database file format or ! for 1D simulations. @@ -62,8 +62,8 @@ contains impure subroutine s_mpi_bcast_user_inputs #ifdef MFC_MPI - integer :: i !< Generic loop iterator - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: i !< Generic loop iterator + integer :: ierr !< Generic flag used to identify and report MPI errors ! Logistics call MPI_BCAST(case_dir, len(case_dir), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) @@ -147,7 +147,7 @@ contains real(wp), dimension(1:, 0:), intent(inout) :: spatial_extents #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors real(wp) :: ext_temp(0:num_procs - 1) ! Simulation is 3D @@ -237,7 +237,7 @@ contains impure subroutine s_mpi_defragment_1d_grid_variable #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors ! Silo-HDF5 database format if (format == 1) then @@ -264,7 +264,7 @@ contains real(wp), dimension(1:2, 0:num_procs - 1), intent(inout) :: data_extents #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors real(wp) :: ext_temp(0:num_procs - 1) if (n > 0) then @@ -299,7 +299,7 @@ contains real(wp), dimension(0:m), intent(inout) :: q_root_sf #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors ! Gathering the sub-domain flow variable data from all the processes and putting it back together for the entire ! computational domain on the process with rank 0 diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 84ee37c02d..af32db4459 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -143,9 +143,12 @@ contains if (proc_rank == 0) then if (cfl_dt) then print '(" [", I3, "%] Saving ", I8, " of ", I0, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', & - & int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), t_step, n_save, wall_time_avg, wall_time + & int(ceiling(100._wp*(real(t_step - n_start)/(n_save)))), t_step, n_save, wall_time_avg, wall_time else - print '(" [", I3, "%] Saving ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), (t_step - t_step_start)/t_step_save + 1, (t_step_stop - t_step_start)/t_step_save + 1, t_step, wall_time_avg, wall_time + print '(" [", I3, "%] Saving ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', & + & int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & + & (t_step - t_step_start)/t_step_save + 1, (t_step_stop - t_step_start)/t_step_save + 1, t_step, & + & wall_time_avg, wall_time end if end if @@ -729,8 +732,8 @@ contains call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' - if (lag_txt_wrt) call s_write_lag_bubbles_results_to_text(t_step) ! text output - if (lag_db_wrt) call s_write_lag_bubbles_to_formatted_database_file(t_step) ! silo file output + if (lag_txt_wrt) call s_write_lag_bubbles_results_to_text(t_step) ! text output + if (lag_db_wrt) call s_write_lag_bubbles_to_formatted_database_file(t_step) ! silo file output end if if (sim_data .and. proc_rank == 0) then diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index 980a8b8627..915c1f6d8d 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -13,7 +13,7 @@ program p_main implicit none - integer :: t_step !< Iterator for the main time-stepping loop + integer :: t_step !< Iterator for the main time-stepping loop !> Generic storage for the name(s) of the flow variable(s) that will be added to the formatted database file(s) character(LEN=name_len) :: varname real(wp) :: pres diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index 060b00c859..be7e5ad00d 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -53,7 +53,7 @@ module m_assign_variables end subroutine s_assign_patch_xxxxx_primitive_variables end interface - private; + private public :: s_initialize_assign_variables_module, s_assign_patch_primitive_variables, & & s_assign_patch_mixture_primitive_variables, s_assign_patch_species_primitive_variables, s_finalize_assign_variables_module @@ -68,9 +68,9 @@ contains ! Select procedure pointer based on multicomponent flow model - if (model_eqns == 1) then ! Gamma/pi_inf model + if (model_eqns == 1) then ! Gamma/pi_inf model s_assign_patch_primitive_variables => s_assign_patch_mixture_primitive_variables - else ! Volume fraction model + else ! Volume fraction model s_assign_patch_primitive_variables => s_assign_patch_species_primitive_variables end if @@ -247,11 +247,11 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf ! Density, gamma, and liquid stiffness from current and smoothing patches - real(wp) :: rho !< density + real(wp) :: rho !< density real(wp) :: gamma - real(wp) :: lit_gamma !< specific heat ratio - real(wp) :: pi_inf !< stiffness from SEOS - real(wp) :: qv !< reference energy from SEOS + real(wp) :: lit_gamma !< specific heat ratio + real(wp) :: pi_inf !< stiffness from SEOS + real(wp) :: qv !< reference energy from SEOS real(wp) :: orig_rho real(wp) :: orig_gamma real(wp) :: orig_pi_inf @@ -261,7 +261,7 @@ contains real(wp) :: rcoord, theta, phi, xi_sph real(wp), dimension(3) :: xi_cart real(wp) :: Ys(1:num_species) - real(stp), dimension(sys_size) :: orig_prim_vf !< Vector to hold original values of cell for smoothing purposes + real(stp), dimension(sys_size) :: orig_prim_vf !< Vector to hold original values of cell for smoothing purposes integer :: i integer :: smooth_patch_id @@ -390,10 +390,10 @@ contains end if if (mhd) then - if (n == 0) then ! 1D: By, Bz + if (n == 0) then ! 1D: By, Bz q_prim_vf(B_idx%beg)%sf(j, k, l) = eta*patch_icpp(patch_id)%By + (1._wp - eta)*orig_prim_vf(B_idx%beg) q_prim_vf(B_idx%beg + 1)%sf(j, k, l) = eta*patch_icpp(patch_id)%Bz + (1._wp - eta)*orig_prim_vf(B_idx%beg + 1) - else ! 2D/3D: Bx, By, Bz + else ! 2D/3D: Bx, By, Bz q_prim_vf(B_idx%beg)%sf(j, k, l) = eta*patch_icpp(patch_id)%Bx + (1._wp - eta)*orig_prim_vf(B_idx%beg) q_prim_vf(B_idx%beg + 1)%sf(j, k, l) = eta*patch_icpp(patch_id)%By + (1._wp - eta)*orig_prim_vf(B_idx%beg + 1) q_prim_vf(B_idx%beg + 2)%sf(j, k, l) = eta*patch_icpp(patch_id)%Bz + (1._wp - eta)*orig_prim_vf(B_idx%beg + 2) @@ -408,7 +408,7 @@ contains end if if (hyperelasticity) then - if (pre_stress) then ! pre stressed initial condition in spatial domain + if (pre_stress) then ! pre stressed initial condition in spatial domain rcoord = sqrt((x_cc(j)**2 + y_cc(k)**2 + z_cc(l)**2)) theta = atan2(y_cc(k), x_cc(j)) phi = atan2(sqrt(x_cc(j)**2 + y_cc(k)**2), z_cc(l)) diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index afbcd7baf5..efcfe7891a 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -13,7 +13,7 @@ module m_check_ib_patches use m_mpi_proxy use m_data_output #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_compile_specific @@ -22,7 +22,7 @@ module m_check_ib_patches implicit none - private; + private public :: s_check_ib_patches character(len=10) :: iStr diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 3e3480b0ee..908f6458f9 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -16,7 +16,7 @@ module m_check_patches use m_mpi_proxy use m_data_output #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_compile_specific diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index bfb2884dd5..9cc26a2342 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -24,7 +24,7 @@ module m_data_output implicit none - private; + private public :: s_write_serial_data_files, s_write_parallel_data_files, s_write_data_files, s_initialize_data_output_module, & & s_finalize_data_output_module @@ -46,7 +46,7 @@ module m_data_output !> Time-step folder into which grid and initial condition data will be placed character(LEN=path_len + 2*name_len), private :: t_step_dir - character(LEN=path_len + 2*name_len), public :: restart_dir !< Restart data folder + character(LEN=path_len + 2*name_len), public :: restart_dir !< Restart data folder procedure(s_write_abstract_data_files), pointer :: s_write_data_files => null() contains @@ -185,11 +185,11 @@ contains else if (((i >= cont_idx%beg) .and. (i <= cont_idx%end)) .or. ((i >= adv_idx%beg) .and. (i <= adv_idx%end) & & ) .or. ((i >= chemxb) .and. (i <= chemxe))) then write (2, FMT) x_cb(j), q_cons_vf(i)%sf(j, 0, 0) - else if (i == mom_idx%beg) then ! u + else if (i == mom_idx%beg) then ! u write (2, FMT) x_cb(j), q_cons_vf(mom_idx%beg)%sf(j, 0, 0)/rho - else if (i == stress_idx%beg) then ! tau_e + else if (i == stress_idx%beg) then ! tau_e write (2, FMT) x_cb(j), q_cons_vf(stress_idx%beg)%sf(j, 0, 0)/rho - else if (i == E_idx) then ! p + else if (i == E_idx) then ! p if (mhd) then pres_mag = 0.5_wp*(Bx0**2 + q_cons_vf(B_idx%beg)%sf(j, 0, 0)**2 + q_cons_vf(B_idx%beg + 1)%sf(j, & & 0, 0)**2) @@ -200,13 +200,13 @@ contains & qv, rhoYks, pres, T, pres_mag=pres_mag) write (2, FMT) x_cb(j), pres else if (mhd) then - if (i == mom_idx%beg + 1) then ! v + if (i == mom_idx%beg + 1) then ! v write (2, FMT) x_cb(j), q_cons_vf(mom_idx%beg + 1)%sf(j, 0, 0)/rho - else if (i == mom_idx%beg + 2) then ! w + else if (i == mom_idx%beg + 2) then ! w write (2, FMT) x_cb(j), q_cons_vf(mom_idx%beg + 2)%sf(j, 0, 0)/rho - else if (i == B_idx%beg) then ! By + else if (i == B_idx%beg) then ! By write (2, FMT) x_cb(j), q_cons_vf(B_idx%beg)%sf(j, 0, 0)/rho - else if (i == B_idx%beg + 1) then ! Bz + else if (i == B_idx%beg + 1) then ! Bz write (2, FMT) x_cb(j), q_cons_vf(B_idx%beg + 1)%sf(j, 0, 0)/rho end if else if ((i >= bub_idx%beg) .and. (i <= bub_idx%end) .and. bubbles_euler) then @@ -406,7 +406,7 @@ contains real(wp) :: loc_violations, glb_violations integer :: m_ds, n_ds, p_ds integer :: m_glb_ds, n_glb_ds, p_glb_ds - integer :: m_glb_save, n_glb_save, p_glb_save ! Size of array being saved + integer :: m_glb_save, n_glb_save, p_glb_save ! Size of array being saved loc_violations = 0._wp diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 7ba8edf582..89e986cf0f 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -8,46 +8,46 @@ module m_global_parameters #ifdef MFC_MPI - use mpi ! Message passing interface (MPI) module + use mpi ! Message passing interface (MPI) module #endif - use m_derived_types ! Definitions of the derived types - use m_helper_basic ! Functions to compare floating point numbers + use m_derived_types ! Definitions of the derived types + use m_helper_basic ! Functions to compare floating point numbers use m_thermochem, only: num_species implicit none ! Logistics - integer :: num_procs !< Number of processors - character(LEN=path_len) :: case_dir !< Case folder location - logical :: old_grid !< Use existing grid data - logical :: old_ic, non_axis_sym !< Use existing IC data - integer :: t_step_old, t_step_start !< Existing IC/grid folder + integer :: num_procs !< Number of processors + character(LEN=path_len) :: case_dir !< Case folder location + logical :: old_grid !< Use existing grid data + logical :: old_ic, non_axis_sym !< Use existing IC data + integer :: t_step_old, t_step_start !< Existing IC/grid folder logical :: cfl_adap_dt, cfl_const_dt, cfl_dt integer :: n_start, n_start_old ! Computational Domain Parameters - integer :: proc_rank !< Rank of the local processor Number of cells in the x-, y- and z-coordinate directions + integer :: proc_rank !< Rank of the local processor Number of cells in the x-, y- and z-coordinate directions integer :: m integer :: n integer :: p !> @name Max and min number of cells in a direction of each combination of x-,y-, and z- type(cell_num_bounds) :: cells_bounds - integer(kind=8) :: nGlobal !< Global number of cells in the domain - integer :: m_glb, n_glb, p_glb !< Global number of cells in each direction - integer :: num_dims !< Number of spatial dimensions - integer :: num_vels !< Number of velocity components (different from num_dims for mhd) + integer(kind=8) :: nGlobal !< Global number of cells in the domain + integer :: m_glb, n_glb, p_glb !< Global number of cells in each direction + integer :: num_dims !< Number of spatial dimensions + integer :: num_vels !< Number of velocity components (different from num_dims for mhd) logical :: cyl_coord - integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) + integer :: grid_geometry !< Cylindrical coordinates (either axisymmetric or full 3D) !> Locations of cell-centers (cc) in x-, y- and z-directions, respectively real(wp), allocatable, dimension(:) :: x_cc, y_cc, z_cc !> Locations of cell-boundaries (cb) in x-, y- and z-directions, respectively real(wp), allocatable, dimension(:) :: x_cb, y_cb, z_cb - real(wp) :: dx, dy, dz !< Minimum cell-widths in the x-, y- and z-coordinate directions - type(bounds_info) :: x_domain, y_domain, z_domain !< Locations of the domain bounds in the x-, y- and z-coordinate directions - logical :: stretch_x, stretch_y, stretch_z !< Grid stretching flags for the x-, y- and z-coordinate directions + real(wp) :: dx, dy, dz !< Minimum cell-widths in the x-, y- and z-coordinate directions + type(bounds_info) :: x_domain, y_domain, z_domain !< Locations of the domain bounds in the x-, y- and z-coordinate directions + logical :: stretch_x, stretch_y, stretch_z !< Grid stretching flags for the x-, y- and z-coordinate directions ! Grid stretching: a_x/a_y/a_z = rate, x_a/y_a/z_a = location real(wp) :: a_x, a_y, a_z integer :: loops_x, loops_y, loops_z @@ -55,104 +55,104 @@ module m_global_parameters real(wp) :: x_b, y_b, z_b ! Simulation Algorithm Parameters - integer :: model_eqns !< Multicomponent flow model - logical :: relax !< activate phase change - integer :: relax_model !< Relax Model - real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model - real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model - integer :: num_fluids !< Number of different fluids present in the flow - logical :: mpp_lim !< Alpha limiter - integer :: sys_size !< Number of unknowns in the system of equations - integer :: recon_type !< Reconstruction Type - integer :: weno_polyn !< Degree of the WENO polynomials (polyn) - integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn) - integer :: weno_order !< Order of accuracy for the WENO reconstruction - integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction - logical :: hypoelasticity !< activate hypoelasticity - logical :: hyperelasticity !< activate hyperelasticity - logical :: elasticity !< elasticity modeling, true for hyper or hypo - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity for RMHD - integer :: b_size !< Number of components in the b tensor - integer :: tensor_size !< Number of components in the nonsymmetric tensor - logical :: pre_stress !< activate pre_stressed domain - logical :: cont_damage !< continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD - logical :: igr !< Use information geometric regularization - integer :: igr_order !< IGR reconstruction order - logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling + integer :: model_eqns !< Multicomponent flow model + logical :: relax !< activate phase change + integer :: relax_model !< Relax Model + real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model + real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model + integer :: num_fluids !< Number of different fluids present in the flow + logical :: mpp_lim !< Alpha limiter + integer :: sys_size !< Number of unknowns in the system of equations + integer :: recon_type !< Reconstruction Type + integer :: weno_polyn !< Degree of the WENO polynomials (polyn) + integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn) + integer :: weno_order !< Order of accuracy for the WENO reconstruction + integer :: muscl_order !< Order of accuracy for the MUSCL reconstruction + logical :: hypoelasticity !< activate hypoelasticity + logical :: hyperelasticity !< activate hyperelasticity + logical :: elasticity !< elasticity modeling, true for hyper or hypo + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity for RMHD + integer :: b_size !< Number of components in the b tensor + integer :: tensor_size !< Number of components in the nonsymmetric tensor + logical :: pre_stress !< activate pre_stressed domain + logical :: cont_damage !< continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD + logical :: igr !< Use information geometric regularization + integer :: igr_order !< IGR reconstruction order + logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling ! Annotations of the structure, i.e. the organization, of the state vectors - type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. - type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of total energy equation - integer :: alf_idx !< Index of void fraction - integer :: n_idx !< Index of number density - type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. - type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. - type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. - type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. - type(int_bounds_info) :: stress_idx !< Indexes of elastic shear stress eqns. - type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: c_idx !< Index of the color function - type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. + type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. + integer :: E_idx !< Index of total energy equation + integer :: alf_idx !< Index of void fraction + integer :: n_idx !< Index of number density + type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. + type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. + type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. + type(int_bounds_info) :: stress_idx !< Indexes of elastic shear stress eqns. + type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. + integer :: c_idx !< Index of the color function + type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD ! Cell Indices for the (local) interior points (O-m, O-n, 0-p). Stands for "InDices With BUFFer". type(int_bounds_info) :: idwint(1:3) ! Cell indices (InDices With BUFFer): includes buffer except in pre_process type(int_bounds_info) :: idwbuff(1:3) - type(int_bounds_info) :: bc_x, bc_y, bc_z !< Boundary conditions in the x-, y- and z-coordinate directions + type(int_bounds_info) :: bc_x, bc_y, bc_z !< Boundary conditions in the x-, y- and z-coordinate directions integer :: shear_num !! Number of shear stress components - integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, !! [indices]) integer, dimension(3, 2) :: shear_BC_flip_indices - logical :: parallel_io !< Format of the data files - logical :: file_per_process !< type of data output - integer :: precision !< Precision of output files - logical :: down_sample !< Down-sample the output data - logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile - real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile - logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow - integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag + logical :: parallel_io !< Format of the data files + logical :: file_per_process !< type of data output + integer :: precision !< Precision of output files + logical :: down_sample !< Down-sample the output data + logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile + real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile + logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow + integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag !> Peak wavenumber of prescribed energy spectra with mixlayer_perturb flag Default value (k0 = 0.4446) is most unstable mode !! obtained from linear stability analysis See Michalke (1964, JFM) for details real(wp) :: mixlayer_perturb_k0 logical :: simplex_perturb type(simplex_noise_params) :: simplex_params - real(wp) :: pi_fac !< Factor for artificial pi_inf + real(wp) :: pi_fac !< Factor for artificial pi_inf logical :: viscous logical :: bubbles_lagrange ! Perturb density of surrounding air so as to break symmetry of grid logical :: perturb_flow - integer :: perturb_flow_fluid !< Fluid to be perturbed with perturb_flow flag - real(wp) :: perturb_flow_mag !< Magnitude of perturbation with perturb_flow flag + integer :: perturb_flow_fluid !< Fluid to be perturbed with perturb_flow flag + real(wp) :: perturb_flow_mag !< Magnitude of perturbation with perturb_flow flag logical :: perturb_sph - integer :: perturb_sph_fluid !< Fluid to be perturbed with perturb_sph flag + integer :: perturb_sph_fluid !< Fluid to be perturbed with perturb_sph flag real(wp), dimension(num_fluids_max) :: fluid_rho logical :: elliptic_smoothing integer :: elliptic_smoothing_iters - integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM - integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid + integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM + integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid #ifdef MFC_MPI type(mpi_io_var), public :: MPI_IO_DATA character(LEN=name_len) :: mpiiofs - integer :: mpi_info_int !< MPI info for parallel IO with Lustre file systems + integer :: mpi_info_int !< MPI info for parallel IO with Lustre file systems #endif ! Initial Condition Parameters - integer :: num_patches !< Number of patches composing initial condition + integer :: num_patches !< Number of patches composing initial condition !> Database of the initial condition patch parameters (icpp) for each of the patches employed in the configuration of the !! initial condition. Note that the maximum allowable number of patches, num_patches_max, may be changed in the module !! m_derived_types.f90. type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp - integer :: num_bc_patches !< Number of boundary condition patches - logical :: bc_io !< whether or not to save BC data + integer :: num_bc_patches !< Number of boundary condition patches + logical :: bc_io !< whether or not to save BC data type(bc_patch_parameters), dimension(num_bc_patches_max) :: patch_bc !! Database of the boundary condition patch parameters for each of the patches employed in the configuration of the boundary !! conditions @@ -163,7 +163,7 @@ module m_global_parameters type(physical_parameters), dimension(num_fluids_max) :: fluid_pp ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp - real(wp) :: rhoref, pref !< Reference parameters for Tait EOS + real(wp) :: rhoref, pref !< Reference parameters for Tait EOS type(chemistry_parameters) :: chem_params !> @name Bubble modeling !> @{ @@ -171,16 +171,16 @@ module m_global_parameters real(wp) :: Ca, Web, Re_inv, Eu real(wp), dimension(:), allocatable :: weight, R0 logical :: bubbles_euler - logical :: qbmm !< Quadrature moment method - integer :: nmom !< Number of carried moments - real(wp) :: sigR, sigV, rhoRV !< standard deviations in R/V - logical :: adv_n !< Solve the number density equation and compute alpha from number density + logical :: qbmm !< Quadrature moment method + integer :: nmom !< Number of carried moments + real(wp) :: sigR, sigV, rhoRV !< standard deviations in R/V + logical :: adv_n !< Solve the number density equation and compute alpha from number density !> @} !> @name Immersed Boundaries !> @{ - logical :: ib !< Turn immersed boundaries on - integer :: num_ibs !< Number of immersed boundaries + logical :: ib !< Turn immersed boundaries on + integer :: num_ibs !< Number of immersed boundaries integer :: Np type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l @@ -194,8 +194,8 @@ module m_global_parameters logical :: polytropic logical :: polydisperse real(wp) :: poly_sigma - integer :: dist_type ! 1 = binormal, 2 = lognormal-normal - integer :: thermal ! 1 = adiabatic, 2 = isotherm, 3 = transfer + integer :: dist_type ! 1 = binormal, 2 = lognormal-normal + integer :: thermal ! 1 = adiabatic, 2 = isotherm, 3 = transfer real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl real(wp) :: gam_m real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g @@ -224,7 +224,7 @@ module m_global_parameters integer, allocatable, dimension(:,:,:) :: logic_grid type(pres_field) :: pb type(pres_field) :: mv - real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) + real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) !> The number of cells that are necessary to be able to store enough boundary conditions data to march the solution in the !! physical computational domain to the next time-step. integer :: buff_size @@ -239,7 +239,7 @@ contains !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs - integer :: i !< Generic loop operator + integer :: i !< Generic loop operator ! Logistics case_dir = '.' @@ -551,8 +551,8 @@ contains bub_pp%gam_g = dflt_real; gam_g = dflt_real bub_pp%M_v = dflt_real; M_v = dflt_real bub_pp%M_g = dflt_real; M_g = dflt_real - bub_pp%k_v = dflt_real; - bub_pp%k_g = dflt_real; + bub_pp%k_v = dflt_real + bub_pp%k_g = dflt_real bub_pp%cp_v = dflt_real; cp_v = dflt_real bub_pp%cp_g = dflt_real; cp_g = dflt_real bub_pp%R_v = dflt_real; R_v = dflt_real @@ -685,9 +685,9 @@ contains if (mhd) then B_idx%beg = sys_size + 1 if (n == 0) then - B_idx%end = sys_size + 2 ! 1D: By, Bz + B_idx%end = sys_size + 2 ! 1D: By, Bz else - B_idx%end = sys_size + 3 ! 2D/3D: Bx, By, Bz + B_idx%end = sys_size + 3 ! 2D/3D: Bx, By, Bz end if sys_size = B_idx%end end if @@ -708,15 +708,15 @@ contains sys_size = internalEnergies_idx%end else if (model_eqns == 4) then ! 4 equation model with subgrid bubbles_euler - cont_idx%beg = 1 ! one continuity equation - cont_idx%end = 1 ! num_fluids - mom_idx%beg = cont_idx%end + 1 ! one momentum equation in each direction + cont_idx%beg = 1 ! one continuity equation + cont_idx%end = 1 ! num_fluids + mom_idx%beg = cont_idx%end + 1 ! one momentum equation in each direction mom_idx%end = cont_idx%end + num_vels - E_idx = mom_idx%end + 1 ! one energy equation + E_idx = mom_idx%end + 1 ! one energy equation adv_idx%beg = E_idx + 1 - adv_idx%end = adv_idx%beg ! one volume advection equation + adv_idx%end = adv_idx%beg ! one volume advection equation alf_idx = adv_idx%end - sys_size = alf_idx ! adv_idx%end + sys_size = alf_idx ! adv_idx%end if (bubbles_euler) then bub_idx%beg = sys_size + 1 @@ -874,11 +874,11 @@ contains end if end if - if (cyl_coord .neqv. .true.) then ! Cartesian grid + if (cyl_coord .neqv. .true.) then ! Cartesian grid grid_geometry = 1 - else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid + else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid grid_geometry = 2 - else ! Fully 3D cylindrical grid + else ! Fully 3D cylindrical grid grid_geometry = 3 end if @@ -892,7 +892,7 @@ contains impure subroutine s_initialize_parallel_io #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors #endif num_dims = 1 + min(1, n) + min(1, p) diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index 40542d3041..927c5961b8 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -5,17 +5,17 @@ !> @brief Generates uniform or stretched rectilinear grids with hyperbolic-tangent spacing module m_grid - use m_derived_types ! Definitions of the derived types - use m_global_parameters ! Global parameters for the code - use m_mpi_proxy ! Message passing interface (MPI) module proxy + use m_derived_types ! Definitions of the derived types + use m_global_parameters ! Global parameters for the code + use m_mpi_proxy ! Message passing interface (MPI) module proxy use m_helper_basic #ifdef MFC_MPI - use mpi ! Message passing interface (MPI) module + use mpi ! Message passing interface (MPI) module #endif implicit none - private; + private public :: s_initialize_grid_module, s_generate_grid, s_generate_serial_grid, s_generate_parallel_grid, s_finalize_grid_module abstract interface @@ -36,8 +36,8 @@ end subroutine s_generate_abstract_grid impure subroutine s_generate_serial_grid ! Generic loop iterator - integer :: i, j !< generic loop operators - real(wp) :: length !< domain lengths + integer :: i, j !< generic loop operators + real(wp) :: length !< domain lengths ! Uniform grid: dx = (x_end - x_beg) / (m + 1) dx = (x_domain%end - x_domain%beg)/real(m + 1, wp) @@ -160,13 +160,13 @@ end subroutine s_generate_serial_grid impure subroutine s_generate_parallel_grid #ifdef MFC_MPI - real(wp) :: length !< domain lengths + real(wp) :: length !< domain lengths ! Locations of cell boundaries - real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb !< Locations of cell boundaries - character(LEN=path_len + name_len) :: file_loc !< Generic string used to store the address of a file + real(wp), allocatable, dimension(:) :: x_cb_glb, y_cb_glb, z_cb_glb !< Locations of cell boundaries + character(LEN=path_len + name_len) :: file_loc !< Generic string used to store the address of a file integer :: ifile, ierr, data_size integer, dimension(MPI_STATUS_SIZE) :: status - integer :: i, j !< Generic loop integers + integer :: i, j !< Generic loop integers allocate (x_cb_glb(-1:m_glb)) allocate (y_cb_glb(-1:n_glb)) diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 8f41d36a47..c0ba4a45da 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -12,8 +12,8 @@ !> @brief Constructs initial condition patch geometries (lines, circles, rectangles, spheres, etc.) on the grid module m_icpp_patches - use m_model ! Subroutine(s) related to STL files - use m_derived_types ! Definitions of the derived types + use m_model ! Subroutine(s) related to STL files + use m_derived_types ! Definitions of the derived types use m_global_parameters use m_constants, only: max_2d_fourier_modes, max_sph_harm_degree, small_radius use m_helper_basic @@ -45,7 +45,7 @@ module m_icpp_patches !! patch boundaries in the x-, y- and z-coordinate directions. They are used as a means to concisely perform the actions !! necessary to lay out a particular patch on the grid. type(bounds_info) :: x_boundary, y_boundary, z_boundary - character(len=5) :: istr ! string to store int to string result for error checking + character(len=5) :: istr ! string to store int to string result for error checking contains @@ -241,7 +241,7 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< Generic loop iterators + integer :: i, j, k !< Generic loop iterators real(wp) :: th, thickness, nturns, mya real(wp) :: spiral_x_min, spiral_x_max, spiral_y_min, spiral_y_max @@ -266,7 +266,7 @@ contains spiral_x_max = maxval((/f_r(th, 0.0_wp, mya)*cos(th), f_r(th, thickness, mya)*cos(th)/)) spiral_y_max = maxval((/f_r(th, 0.0_wp, mya)*sin(th), f_r(th, thickness, mya)*sin(th)/)) - do j = 0, n; do i = 0, m; + do j = 0, n; do i = 0, m if ((x_cc(i) > spiral_x_min) .and. (x_cc(i) < spiral_x_max) .and. (y_cc(j) > spiral_y_min) .and. (y_cc(j) & & < spiral_y_max)) then logic_grid(i, j, 0) = 1 @@ -310,7 +310,7 @@ contains #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf real(wp) :: radius - integer :: i, j, k !< Generic loop iterators + integer :: i, j, k !< Generic loop iterators @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -492,7 +492,7 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< Generic loop operators + integer :: i, j, k !< Generic loop operators real(wp) :: a, b @:HardcodedDimensionsExtrusion() @@ -627,8 +627,8 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< generic loop iterators - real(wp) :: pi_inf, gamma, lit_gamma !< Equation of state parameters + integer :: i, j, k !< generic loop iterators + real(wp) :: pi_inf, gamma, lit_gamma !< Equation of state parameters @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -700,7 +700,7 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< Generic loop operators + integer :: i, j, k !< Generic loop operators real(wp) :: a, b, c @:HardcodedDimensionsExtrusion() @@ -760,9 +760,9 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< generic loop iterators - real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters - real(wp) :: L0, U0 !< Taylor Green Vortex parameters + integer :: i, j, k !< generic loop iterators + real(wp) :: pi_inf, gamma, lit_gamma !< equation of state parameters + real(wp) :: L0, U0 !< Taylor Green Vortex parameters @:HardcodedDimensionsExtrusion() @:Hardcoded2DVariables() @@ -1083,7 +1083,7 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< Generic loop iterators + integer :: i, j, k !< Generic loop iterators @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() @@ -1156,7 +1156,7 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< Generic loop iterators + integer :: i, j, k !< Generic loop iterators real(wp) :: radius @:HardcodedDimensionsExtrusion() @@ -1254,7 +1254,7 @@ contains integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf - integer :: i, j, k !< Generic loop iterators + integer :: i, j, k !< Generic loop iterators real(wp) :: a, b, c, d @:HardcodedDimensionsExtrusion() @@ -1327,12 +1327,12 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf ! Variables for IBM+STL - real(wp) :: normals(1:3) !< Boundary normal buffer - integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex - real(wp), allocatable, dimension(:,:,:) :: boundary_v !< Boundary vertex buffer - real(wp) :: distance !< Levelset distance buffer - logical :: interpolate !< Logical variable to determine whether or not the model should be interpolated - integer :: i, j, k !< Generic loop iterators + real(wp) :: normals(1:3) !< Boundary normal buffer + integer :: boundary_vertex_count, boundary_edge_count, total_vertices !< Boundary vertex + real(wp), allocatable, dimension(:,:,:) :: boundary_v !< Boundary vertex buffer + real(wp) :: distance !< Levelset distance buffer + logical :: interpolate !< Logical variable to determine whether or not the model should be interpolated + integer :: i, j, k !< Generic loop iterators type(t_bbox) :: bbox, bbox_old type(t_model) :: model type(ic_model_parameters) :: params diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 696901dc7b..42bdb0ff88 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -19,10 +19,10 @@ module m_initial_condition implicit none ! NOTE: Abstract interface enables dynamic dispatch without repeated model_eqns checks - type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< primitive variables - type(scalar_field), allocatable, dimension(:) :: q_cons_vf !< conservative variables - type(scalar_field) :: q_T_sf !< Temperature field - type(integer_field), dimension(:,:), allocatable :: bc_type !< bc_type fields + type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< primitive variables + type(scalar_field), allocatable, dimension(:) :: q_cons_vf !< conservative variables + type(scalar_field) :: q_T_sf !< Temperature field + type(integer_field), dimension(:,:), allocatable :: bc_type !< bc_type fields !> @cond #ifdef MFC_MIXED_PRECISION integer(kind=1), allocatable, dimension(:,:,:) :: patch_id_fp @@ -60,8 +60,8 @@ contains end if do i = 1, sys_size - q_cons_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) ! TODO :: remove this magic number - q_prim_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) + q_cons_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) ! TODO :: remove this magic number + q_prim_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) end do allocate (bc_type(1:num_dims, 1:2)) diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 8692fb2900..649887306e 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -36,7 +36,7 @@ module m_start_up implicit none - private; + private public :: s_read_input_file, s_check_input_file, s_read_grid_data_files, s_read_ic_data_files, s_read_serial_grid_data_files, & & s_read_serial_ic_data_files, s_read_parallel_grid_data_files, s_read_parallel_ic_data_files, s_check_grid_data_files, & & s_initialize_modules, s_initialize_mpi_domain, s_finalize_modules, s_apply_initial_condition, s_save_data, s_read_grid @@ -59,7 +59,7 @@ module m_start_up end subroutine s_read_abstract_ic_data_files end interface - character(LEN=path_len + name_len) :: proc_rank_dir !< Location of the folder associated with the rank of the local processor + character(LEN=path_len + name_len) :: proc_rank_dir !< Location of the folder associated with the rank of the local processor !> Possible location of time-step folder containing preexisting grid and/or conservative variables data to be used as starting !! point for pre-process character(LEN=path_len + 2*name_len), private :: t_step_dir diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index bfa4488473..40fb9593e7 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -49,10 +49,10 @@ module m_acoustic_src !> @} $:GPU_DECLARE(create='[mass_src, e_src, mom_src]') - integer, dimension(:), allocatable :: source_spatials_num_points !< Number of non-zero source grid points for each source + integer, dimension(:), allocatable :: source_spatials_num_points !< Number of non-zero source grid points for each source $:GPU_DECLARE(create='[source_spatials_num_points]') - type(source_spatial_type), dimension(:), allocatable :: source_spatials !< Data of non-zero source grid points for each source + type(source_spatial_type), dimension(:), allocatable :: source_spatials !< Data of non-zero source grid points for each source $:GPU_DECLARE(create='[source_spatials]') contains @@ -60,7 +60,7 @@ contains !> This subroutine initializes the acoustic source module impure subroutine s_initialize_acoustic_src - integer :: i, j !< generic loop variables + integer :: i, j !< generic loop variables @:ALLOCATE(loc_acoustic(1:3, 1:num_source), mag(1:num_source), dipole(1:num_source), support(1:num_source), & & length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), & @@ -105,8 +105,8 @@ contains else rotate_angle(i) = acoustic(i)%rotate_angle end if - if (f_is_default(acoustic(i)%delay)) then ! m_checker guarantees acoustic(i)%delay is set for pulse = 2 (Gaussian) - delay(i) = 0._wp ! Defaults to zero for sine and square waves + if (f_is_default(acoustic(i)%delay)) then ! m_checker guarantees acoustic(i)%delay is set for pulse = 2 (Gaussian) + delay(i) = 0._wp ! Defaults to zero for sine and square waves else delay(i) = acoustic(i)%delay end if @@ -127,8 +127,8 @@ contains !! @param rhs_vf rhs variables impure subroutine s_acoustic_src_calculations(q_cons_vf, q_prim_vf, rhs_vf) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Conservative variables - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive variables + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Conservative variables + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive variables type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -141,18 +141,18 @@ contains real(wp) :: frequency_local, gauss_sigma_time_local real(wp) :: mass_src_diff, mom_src_diff real(wp) :: source_temporal - real(wp) :: period_BB !< period of each sine wave in broadband source - real(wp) :: sl_BB !< spectral level at each frequency - real(wp) :: ffre_BB !< source term corresponding to each frequency - real(wp) :: sum_BB !< total source term for the broadband wave - real(wp), allocatable, dimension(:) :: phi_rn !< random phase shift for each frequency - integer :: i, j, k, l, q !< generic loop variables - integer :: ai !< acoustic source index + real(wp) :: period_BB !< period of each sine wave in broadband source + real(wp) :: sl_BB !< spectral level at each frequency + real(wp) :: ffre_BB !< source term corresponding to each frequency + real(wp) :: sum_BB !< total source term for the broadband wave + real(wp), allocatable, dimension(:) :: phi_rn !< random phase shift for each frequency + integer :: i, j, k, l, q !< generic loop variables + integer :: ai !< acoustic source index integer :: num_points logical :: freq_conv_flag, gauss_conv_flag integer, parameter :: mass_label = 1, mom_label = 2 - sim_time = mytime ! Accumulated time, correct under adaptive dt + sim_time = mytime ! Accumulated time, correct under adaptive dt $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p @@ -176,7 +176,7 @@ contains freq_conv_flag = f_is_default(frequency(ai)) gauss_conv_flag = f_is_default(gauss_sigma_time(ai)) - num_points = source_spatials_num_points(ai) ! Use scalar to force firstprivate to prevent GPU bug + num_points = source_spatials_num_points(ai) ! Use scalar to force firstprivate to prevent GPU bug ! Calculate the broadband source period_BB = 0._wp @@ -262,24 +262,24 @@ contains & sum_BB) mom_src_diff = source_temporal*source_spatials(ai)%val(i) - if (dipole(ai)) then ! Double amplitude & No momentum source term (only works for Planar) + if (dipole(ai)) then ! Double amplitude & No momentum source term (only works for Planar) mass_src(j, k, l) = mass_src(j, k, l) + 2._wp*mom_src_diff/c if (model_eqns /= 4) E_src(j, k, l) = E_src(j, k, l) + 2._wp*mom_src_diff*c/(small_gamma - 1._wp) cycle end if - if (n == 0) then ! 1D - mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*sign(1._wp, dir(ai)) ! Left or right-going wave - else if (p == 0) then ! 2D - if (support(ai) < 5) then ! Planar + if (n == 0) then ! 1D + mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*sign(1._wp, dir(ai)) ! Left or right-going wave + else if (p == 0) then ! 2D + if (support(ai) < 5) then ! Planar mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(dir(ai)) mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*sin(dir(ai)) else mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(source_spatials(ai)%angle(i)) mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*sin(source_spatials(ai)%angle(i)) end if - else ! 3D - if (support(ai) < 5) then ! Planar + else ! 3D + if (support(ai) < 5) then ! Planar mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(dir(ai)) mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*sin(dir(ai)) else @@ -290,9 +290,9 @@ contains end if ! Update mass source term - if (support(ai) < 5) then ! Planar + if (support(ai) < 5) then ! Planar mass_src_diff = mom_src_diff/c - else ! Spherical or cylindrical support + else ! Spherical or cylindrical support ! Mass source term must be calculated differently using a correction term for spherical and cylindrical ! support call s_source_temporal(sim_time, c, ai, mass_label, frequency_local, gauss_sigma_time_local, & @@ -347,24 +347,24 @@ contains real(wp), intent(in) :: sim_time, c, sum_BB real(wp), intent(in) :: frequency_local, gauss_sigma_time_local real(wp), intent(out) :: source - real(wp) :: omega ! angular frequency - real(wp) :: sine_wave ! sine function for square wave - real(wp) :: foc_length_factor ! Scale amplitude with radius for spherical support + real(wp) :: omega ! angular frequency + real(wp) :: sine_wave ! sine function for square wave + real(wp) :: foc_length_factor ! Scale amplitude with radius for spherical support ! i.e. Spherical support -> 1/r scaling; Cylindrical support -> 1/sqrt(r) [empirical correction: ^-0.5 -> ^-0.85] integer, parameter :: mass_label = 1 if (n == 0) then foc_length_factor = 1._wp - else if (p == 0 .and. (.not. cyl_coord)) then ! 2D axisymmetric case is physically 3D - foc_length_factor = foc_length(ai)**(-0.85_wp); ! Empirical correction + else if (p == 0 .and. (.not. cyl_coord)) then ! 2D axisymmetric case is physically 3D + foc_length_factor = foc_length(ai)**(-0.85_wp) ! Empirical correction else - foc_length_factor = 1/foc_length(ai); + foc_length_factor = 1/foc_length(ai) end if source = 0._wp ! Temporal waveform: sine, Gaussian pulse, square wave, or broadband - if (pulse(ai) == 1) then ! Sine wave + if (pulse(ai) == 1) then ! Sine wave if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return omega = 2._wp*pi*frequency_local @@ -373,14 +373,14 @@ contains if (term_index == mass_label) then source = source/c + foc_length_factor*mag(ai)*(cos((sim_time - delay(ai))*omega) - 1._wp)/omega end if - else if (pulse(ai) == 2) then ! Gaussian pulse + else if (pulse(ai) == 2) then ! Gaussian pulse source = mag(ai)*exp(-0.5_wp*((sim_time - delay(ai))**2._wp)/(gauss_sigma_time_local**2._wp)) if (term_index == mass_label) then source = source/c - foc_length_factor*mag(ai)*sqrt(pi/2)*gauss_sigma_time_local*(erf((sim_time - delay(ai)) & - & /(sqrt(2._wp)*gauss_sigma_time_local)) + 1) + & /(sqrt(2._wp)*gauss_sigma_time_local)) + 1) end if - else if (pulse(ai) == 3) then ! Square wave + else if (pulse(ai) == 3) then ! Square wave if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return omega = 2._wp*pi*frequency_local @@ -391,7 +391,7 @@ contains if (abs(sine_wave) < 1.e-2_wp) then source = mag(ai)*sine_wave*1.e2_wp end if - else if (pulse(ai) == 4) then ! Broadband wave + else if (pulse(ai) == 4) then ! Broadband wave source = sum_BB end if @@ -441,7 +441,7 @@ contains @:ACC_SETUP_source_spatials(source_spatials(ai)) ! Second pass: Store the values - count = 0 ! Reset counter + count = 0 ! Reset counter do l = 0, p do k = 0, n do j = 0, m @@ -542,14 +542,14 @@ contains source = 0._wp ! Gaussian spatial pulse profile: exp(-0.5 * (d / sigma)^2) / (sqrt(2*pi) * sigma) - if (support(ai) == 1) then ! 1D + if (support(ai) == 1) then ! 1D source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(r(1)/(sig/2._wp))**2._wp) - else if (support(ai) == 2 .or. support(ai) == 3) then ! 2D or 3D + else if (support(ai) == 2 .or. support(ai) == 3) then ! 2D or 3D ! If we let unit vector e = (cos(dir), sin(dir)), - dist = r(1)*cos(dir(ai)) + r(2)*sin(dir(ai)) ! dot(r,e) + dist = r(1)*cos(dir(ai)) + r(2)*sin(dir(ai)) ! dot(r,e) if ((r(1) - dist*cos(dir(ai)))**2._wp + (r(2) - dist*sin(dir(ai)))**2._wp < 0.25_wp*length(ai)**2._wp) & - & then ! |r - dist*e| < length/2 - if (support(ai) /= 3 .or. abs(r(3)) < 0.25_wp*height(ai)) then ! additional height constraint for 3D + & then ! |r - dist*e| < length/2 + if (support(ai) /= 3 .or. abs(r(3)) < 0.25_wp*height(ai)) then ! additional height constraint for 3D source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(dist/(sig/2._wp))**2._wp) end if end if @@ -571,11 +571,11 @@ contains real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3) real(wp) :: current_angle, angle_half_aperture, dist, norm - source = 0._wp ! If not affected by transducer + source = 0._wp ! If not affected by transducer angle = 0._wp xyz_to_r_ratios = 0._wp - if (support(ai) == 5 .or. support(ai) == 6) then ! 2D or 2D axisymmetric + if (support(ai) == 5 .or. support(ai) == 6) then ! 2D or 2D axisymmetric current_angle = -atan(r(2)/(foc_length(ai) - r(1))) angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai))) @@ -584,7 +584,7 @@ contains source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(dist/(sig/2._wp))**2._wp) angle = -atan(r(2)/(foc_length(ai) - r(1))) end if - else if (support(ai) == 7) then ! 3D + else if (support(ai) == 7) then ! 3D current_angle = -atan(sqrt(r(2)**2 + r(3)**2)/(foc_length(ai) - r(1))) angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai))) @@ -619,19 +619,19 @@ contains real(wp) :: poly_side_length, aperture_element_3D, angle_elem real(wp) :: x2, y2, z2, x3, y3, z3, C, f, half_apert, dist_interp_to_elem_center - if (element_on(ai) == 0) then ! Full transducer + if (element_on(ai) == 0) then ! Full transducer elem_min = 1 elem_max = num_elements(ai) - else ! Transducer element specified + else ! Transducer element specified elem_min = element_on(ai) elem_max = element_on(ai) end if - source = 0._wp ! If not affected by any transducer element + source = 0._wp ! If not affected by any transducer element angle = 0._wp xyz_to_r_ratios = 0._wp - if (support(ai) == 9 .or. support(ai) == 10) then ! 2D or 2D axisymmetric + if (support(ai) == 9 .or. support(ai) == 10) then ! 2D or 2D axisymmetric current_angle = -atan(r(2)/(foc_length(ai) - r(1))) angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai))) angle_per_elem = (2._wp*angle_half_aperture - (num_elements(ai) - 1._wp)*element_spacing_angle(ai))/num_elements(ai) @@ -644,10 +644,10 @@ contains if (current_angle > angle_min .and. current_angle < angle_max .and. r(1) < foc_length(ai)) then source = exp(-0.5_wp*(dist/(sig/2._wp))**2._wp)/(sqrt(2._wp*pi)*sig/2._wp) angle = current_angle - exit ! Assume elements don't overlap + exit ! Assume elements don't overlap end if end do - else if (support(ai) == 11) then ! 3D + else if (support(ai) == 11) then ! 3D poly_side_length = aperture(ai)*sin(pi/num_elements(ai)) aperture_element_3D = poly_side_length*element_polygon_ratio(ai) f = foc_length(ai) @@ -663,7 +663,7 @@ contains ! Construct a plane normal to the line from the focal point to the elem center, Point 3 is the intercept of the ! plane and the line from the focal point to the current location - C = f**2._wp/((r(1) - f)*(x2 - f) + r(2)*y2 + r(3)*z2) ! Constant for intermediate step + C = f**2._wp/((r(1) - f)*(x2 - f) + r(2)*y2 + r(3)*z2) ! Constant for intermediate step x3 = C*(r(1) - f) + f y3 = C*r(2) z3 = C*r(3) diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index d0bd16a9b1..e061608c7e 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -16,7 +16,7 @@ module m_body_forces implicit none - private; + private public :: s_compute_body_forces_rhs, s_initialize_body_forces_module, s_finalize_body_forces_module real(wp), allocatable, dimension(:,:,:) :: rhoM @@ -59,7 +59,7 @@ contains subroutine s_compute_mixture_density(q_cons_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - integer :: i, j, k, l !< standard iterators + integer :: i, j, k, l !< standard iterators $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p @@ -85,7 +85,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - integer :: i, j, k, l !< Loop variables + integer :: i, j, k, l !< Loop variables call s_compute_acceleration(mytime) call s_compute_mixture_density(q_cons_vf) @@ -102,7 +102,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() - if (bf_x) then ! x-direction body forces + if (bf_x) then ! x-direction body forces $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p @@ -116,7 +116,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if - if (bf_y) then ! y-direction body forces + if (bf_y) then ! y-direction body forces $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p @@ -130,7 +130,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if - if (bf_z) then ! z-direction body forces + if (bf_z) then ! z-direction body forces $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 201f1b180b..771059b750 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -15,9 +15,9 @@ module m_bubbles use m_helper_basic implicit none - real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) - real(wp) :: k_mw !< Bubble wall properties (Ando 2010) - real(wp) :: rho_mw !< Bubble wall properties (Ando 2010) + real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) + real(wp) :: k_mw !< Bubble wall properties (Ando 2010) + real(wp) :: rho_mw !< Bubble wall properties (Ando 2010) $:GPU_DECLARE(create='[chi_vw, k_mw, rho_mw]') contains @@ -301,9 +301,9 @@ contains $:GPU_ROUTINE(parallelism='[seq]') real(wp), intent(in) :: pb_in integer, intent(in) :: iR0 - real(wp), intent(out) :: chi_vw_out !< Bubble wall properties (Ando 2010) - real(wp), intent(out) :: k_mw_out !< Bubble wall properties (Ando 2010) - real(wp), intent(out) :: rho_mw_out !< Bubble wall properties (Ando 2010) + real(wp), intent(out) :: chi_vw_out !< Bubble wall properties (Ando 2010) + real(wp), intent(out) :: k_mw_out !< Bubble wall properties (Ando 2010) + real(wp), intent(out) :: rho_mw_out !< Bubble wall properties (Ando 2010) real(wp) :: x_vw ! mass fraction of vapor @@ -343,7 +343,7 @@ contains real(wp) :: grad_chi real(wp) :: conc_v - if (thermal == 3) then ! transfer + if (thermal == 3) then ! transfer ! constant transfer model if (bubbles_lagrange) then ! Mixture properties (gas+vapor) in the bubble @@ -448,12 +448,12 @@ contains integer, intent(in) :: bub_id real(wp), intent(in) :: fmass_g, fbeta_c, fbeta_t, fCson integer, intent(inout) :: adap_dt_stop - real(wp), dimension(5) :: err !< Error estimates for adaptive time stepping - real(wp) :: t_new !< Updated time step size - real(wp) :: h0, h !< Time step size + real(wp), dimension(5) :: err !< Error estimates for adaptive time stepping + real(wp) :: t_new !< Updated time step size + real(wp) :: h0, h !< Time step size !> Bubble radius, radial velocity, and radial acceleration for the inner loop real(wp), dimension(4) :: myR_tmp1, myV_tmp1, myR_tmp2, myV_tmp2 - real(wp), dimension(4) :: myPb_tmp1, myMv_tmp1, myPb_tmp2, myMv_tmp2 !< Gas pressure and vapor mass for the inner loop (EL) + real(wp), dimension(4) :: myPb_tmp1, myMv_tmp1, myPb_tmp2, myMv_tmp2 !< Gas pressure and vapor mass for the inner loop (EL) real(wp) :: fR2, fV2, fpb2, fmass_v2 integer :: iter_count @@ -569,9 +569,9 @@ contains real(wp), intent(in) :: fntait, fBtait, f_bub_adv_src, f_divu real(wp), intent(in) :: fCson real(wp), intent(out) :: h - real(wp), dimension(2) :: h_size !< Time step size (h0, h1) - real(wp), dimension(3) :: d_norms !< norms (d_0, d_1, d_2) - real(wp), dimension(2) :: myR_tmp, myV_tmp, myA_tmp !< Bubble radius, radial velocity, and radial acceleration + real(wp), dimension(2) :: h_size !< Time step size (h0, h1) + real(wp), dimension(3) :: d_norms !< norms (d_0, d_1, d_2) + real(wp), dimension(2) :: myR_tmp, myV_tmp, myA_tmp !< Bubble radius, radial velocity, and radial acceleration ! Determine the starting time step Evaluate f(x0,y0) myR_tmp(1) = fR myV_tmp(1) = fV diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index eef4d01d5c..459bb51e92 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -18,7 +18,7 @@ module m_bubbles_EE real(wp), allocatable, dimension(:,:,:,:) :: bub_r_src, bub_v_src, bub_p_src, bub_m_src $:GPU_DECLARE(create='[bub_adv_src, bub_r_src, bub_v_src, bub_p_src, bub_m_src]') - type(scalar_field) :: divu !< matrix for div(u) + type(scalar_field) :: divu !< matrix for div(u) $:GPU_DECLARE(create='[divu]') integer, allocatable, dimension(:) :: rs, vs, ms, ps @@ -96,7 +96,7 @@ contains integer, intent(in) :: idir type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), intent(inout) :: divu_in !< matrix for div(u) + type(scalar_field), intent(inout) :: divu_in !< matrix for div(u) integer :: j, k, l if (idir == 1) then @@ -148,7 +148,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - type(scalar_field), intent(in) :: divu_in !< matrix for div(u) + type(scalar_field), intent(in) :: divu_in !< matrix for div(u) real(wp) :: rddot real(wp) :: pb_local, mv_local, vflux, pbdot real(wp) :: n_tait, B_tait @@ -161,11 +161,11 @@ contains real(wp), dimension(num_fluids) :: myalpha, myalpha_rho #:endif real(wp) :: myR, myV, alf, myP, myRho, R2Vav, R3 - real(wp) :: nbub !< Bubble number density + real(wp) :: nbub !< Bubble number density real(wp) :: my_divu - integer :: i, j, k, l, q, ii !< Loop variables - integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached - integer :: dmBub_id !< Dummy variables for unified subgrid bubble subroutines + integer :: i, j, k, l, q, ii !< Loop variables + integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached + integer :: dmBub_id !< Dummy variables for unified subgrid bubble subroutines real(wp) :: dmMass_v, dmMass_n, dmBeta_c, dmBeta_t, dmCson $:GPU_PARALLEL_LOOP(private='[j, k, l, q]', collapse=3) @@ -248,8 +248,8 @@ contains end do end if - n_tait = 1._wp/n_tait + 1._wp ! make this the usual little 'gamma' - B_tait = B_tait*(n_tait - 1)/n_tait ! make this the usual pi_inf + n_tait = 1._wp/n_tait + 1._wp ! make this the usual little 'gamma' + B_tait = B_tait*(n_tait - 1)/n_tait ! make this the usual pi_inf myP = q_prim_vf(E_idx)%sf(j, k, l) alf = q_prim_vf(alf_idx)%sf(j, k, l) diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index fa06d43877..41942cd447 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -21,47 +21,47 @@ module m_bubbles_EL implicit none ! (nBub) - integer, allocatable, dimension(:,:) :: lag_id !< Global and local IDs - real(wp), allocatable, dimension(:) :: bub_R0 !< Initial bubble radius - real(wp), allocatable, dimension(:) :: Rmax_stats !< Maximum radius - real(wp), allocatable, dimension(:) :: Rmin_stats !< Minimum radius + integer, allocatable, dimension(:,:) :: lag_id !< Global and local IDs + real(wp), allocatable, dimension(:) :: bub_R0 !< Initial bubble radius + real(wp), allocatable, dimension(:) :: Rmax_stats !< Maximum radius + real(wp), allocatable, dimension(:) :: Rmin_stats !< Minimum radius $:GPU_DECLARE(create='[lag_id, bub_R0, Rmax_stats, Rmin_stats]') - real(wp), allocatable, dimension(:) :: gas_mg !< Bubble's gas mass - real(wp), allocatable, dimension(:) :: gas_betaT !< heatflux model (Preston et al., 2007) - real(wp), allocatable, dimension(:) :: gas_betaC !< massflux model (Preston et al., 2007) - real(wp), allocatable, dimension(:) :: bub_dphidt !< subgrid velocity potential (Maeda & Colonius, 2018) + real(wp), allocatable, dimension(:) :: gas_mg !< Bubble's gas mass + real(wp), allocatable, dimension(:) :: gas_betaT !< heatflux model (Preston et al., 2007) + real(wp), allocatable, dimension(:) :: gas_betaC !< massflux model (Preston et al., 2007) + real(wp), allocatable, dimension(:) :: bub_dphidt !< subgrid velocity potential (Maeda & Colonius, 2018) $:GPU_DECLARE(create='[gas_mg, gas_betaT, gas_betaC, bub_dphidt]') ! (nBub, 1 -> actual val or 2 -> temp val) - real(wp), allocatable, dimension(:,:) :: gas_p !< Pressure in the bubble - real(wp), allocatable, dimension(:,:) :: gas_mv !< Vapor mass in the bubble - real(wp), allocatable, dimension(:,:) :: intfc_rad !< Bubble radius - real(wp), allocatable, dimension(:,:) :: intfc_vel !< Velocity of the bubble interface + real(wp), allocatable, dimension(:,:) :: gas_p !< Pressure in the bubble + real(wp), allocatable, dimension(:,:) :: gas_mv !< Vapor mass in the bubble + real(wp), allocatable, dimension(:,:) :: intfc_rad !< Bubble radius + real(wp), allocatable, dimension(:,:) :: intfc_vel !< Velocity of the bubble interface $:GPU_DECLARE(create='[gas_p, gas_mv, intfc_rad, intfc_vel]') ! (nBub, 1-> x or 2->y or 3 ->z, 1 -> actual or 2 -> temporal val) - real(wp), allocatable, dimension(:,:,:) :: mtn_pos !< Bubble's position - real(wp), allocatable, dimension(:,:,:) :: mtn_posPrev !< Bubble's previous position - real(wp), allocatable, dimension(:,:,:) :: mtn_vel !< Bubble's velocity - real(wp), allocatable, dimension(:,:,:) :: mtn_s !< Bubble's computational cell position in real format + real(wp), allocatable, dimension(:,:,:) :: mtn_pos !< Bubble's position + real(wp), allocatable, dimension(:,:,:) :: mtn_posPrev !< Bubble's previous position + real(wp), allocatable, dimension(:,:,:) :: mtn_vel !< Bubble's velocity + real(wp), allocatable, dimension(:,:,:) :: mtn_s !< Bubble's computational cell position in real format $:GPU_DECLARE(create='[mtn_pos, mtn_posPrev, mtn_vel, mtn_s]') ! (nBub, 1-> x or 2->y or 3 ->z, time-stage) - real(wp), allocatable, dimension(:,:) :: intfc_draddt !< Time derivative of bubble's radius - real(wp), allocatable, dimension(:,:) :: intfc_dveldt !< Time derivative of bubble's interface velocity - real(wp), allocatable, dimension(:,:) :: gas_dpdt !< Time derivative of gas pressure - real(wp), allocatable, dimension(:,:) :: gas_dmvdt !< Time derivative of the vapor mass in the bubble - real(wp), allocatable, dimension(:,:,:) :: mtn_dposdt !< Time derivative of the bubble's position - real(wp), allocatable, dimension(:,:,:) :: mtn_dveldt !< Time derivative of the bubble's velocity + real(wp), allocatable, dimension(:,:) :: intfc_draddt !< Time derivative of bubble's radius + real(wp), allocatable, dimension(:,:) :: intfc_dveldt !< Time derivative of bubble's interface velocity + real(wp), allocatable, dimension(:,:) :: gas_dpdt !< Time derivative of gas pressure + real(wp), allocatable, dimension(:,:) :: gas_dmvdt !< Time derivative of the vapor mass in the bubble + real(wp), allocatable, dimension(:,:,:) :: mtn_dposdt !< Time derivative of the bubble's position + real(wp), allocatable, dimension(:,:,:) :: mtn_dveldt !< Time derivative of the bubble's velocity $:GPU_DECLARE(create='[intfc_draddt, intfc_dveldt, gas_dpdt, gas_dmvdt, mtn_dposdt, mtn_dveldt]') - integer, private :: lag_num_ts !< Number of time stages in the time-stepping scheme + integer, private :: lag_num_ts !< Number of time stages in the time-stepping scheme $:GPU_DECLARE(create='[lag_num_ts]') - integer :: nBubs !< Number of bubbles in the local domain - real(wp) :: Rmax_glb, Rmin_glb !< Maximum and minimum bubbe size in the local domain + integer :: nBubs !< Number of bubbles in the local domain + real(wp) :: Rmax_glb, Rmin_glb !< Maximum and minimum bubbe size in the local domain !> Projection of the lagrangian particles in the Eulerian framework type(scalar_field), dimension(:), allocatable :: q_beta - integer :: q_beta_idx !< Size of the q_beta vector field + integer :: q_beta_idx !< Size of the q_beta vector field $:GPU_DECLARE(create='[nBubs, Rmax_glb, Rmin_glb, q_beta, q_beta_idx]') contains @@ -178,9 +178,9 @@ contains if (indomain) then bub_id = bub_id + 1 call s_add_bubbles(inputBubble, q_cons_vf, bub_id) - lag_id(bub_id, 1) = id ! global ID - lag_id(bub_id, 2) = bub_id ! local ID - nBubs = bub_id ! local number of bubbles + lag_id(bub_id, 1) = id ! global ID + lag_id(bub_id, 2) = bub_id ! local ID + nBubs = bub_id ! local number of bubbles end if end do close (94) @@ -217,7 +217,7 @@ contains write (path_D_dir, '(A,I0,A,I0)') trim(case_dir) // '/D' call my_inquire(path_D_dir, file_exist) if (.not. file_exist) call s_create_directory(trim(path_D_dir)) - call s_write_restart_lag_bubbles(save_count) ! Needed for post_processing + call s_write_restart_lag_bubbles(save_count) ! Needed for post_processing call s_write_void_evol(qtime) end if @@ -300,13 +300,13 @@ contains end if ! Initial particle mass - volparticle = 4._wp/3._wp*pi*bub_R0(bub_id)**3._wp ! volume - gas_mv(bub_id, 1) = pv*volparticle*(1._wp/(R_v*Tw))*(massflag) ! vapermass - gas_mg(bub_id) = (gas_p(bub_id, 1) - pv*(massflag))*volparticle*(1._wp/(R_g*Tw)) ! gasmass + volparticle = 4._wp/3._wp*pi*bub_R0(bub_id)**3._wp ! volume + gas_mv(bub_id, 1) = pv*volparticle*(1._wp/(R_v*Tw))*(massflag) ! vapermass + gas_mg(bub_id) = (gas_p(bub_id, 1) - pv*(massflag))*volparticle*(1._wp/(R_g*Tw)) ! gasmass if (gas_mg(bub_id) <= 0._wp) then call s_mpi_abort("The initial mass of gas inside the bubble is negative. Check the initial conditions.") end if - totalmass = gas_mg(bub_id) + gas_mv(bub_id, 1) ! totalmass + totalmass = gas_mg(bub_id) + gas_mv(bub_id, 1) ! totalmass ! Bubble natural frequency concvap = gas_mv(bub_id, 1)/(gas_mv(bub_id, 1) + gas_mg(bub_id)) @@ -511,8 +511,8 @@ contains #:endif real(wp), dimension(2) :: Re integer, dimension(3) :: cell - integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached - real(wp) :: dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu !< Dummy variables for unified subgrid bubble subroutines + integer :: adap_dt_stop_max, adap_dt_stop !< Fail-safe exit if max iteration count reached + real(wp) :: dmalf, dmntait, dmBtait, dm_bub_adv_src, dm_divu !< Dummy variables for unified subgrid bubble subroutines integer :: i, k, l call nvtxStartRange("LAGRANGE-BUBBLE-DYNAMICS") @@ -872,12 +872,12 @@ contains end if !> Perform bilinear interpolation - if (p == 0) then ! 2D + if (p == 0) then ! 2D f_pinfl = q_prim_vf(E_idx)%sf(cell(1), cell(2), cell(3))*(1._wp - psi(1))*(1._wp - psi(2)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2), cell(3))*psi(1)*(1._wp - psi(2)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2) + 1, cell(3))*psi(1)*psi(2) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1), cell(2) + 1, cell(3))*(1._wp - psi(1))*psi(2) - else ! 3D + else ! 3D f_pinfl = q_prim_vf(E_idx)%sf(cell(1), cell(2), cell(3))*(1._wp - psi(1))*(1._wp - psi(2))*(1._wp - psi(3)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2), cell(3))*psi(1)*(1._wp - psi(2))*(1._wp - psi(3)) f_pinfl = f_pinfl + q_prim_vf(E_idx)%sf(cell(1) + 1, cell(2) + 1, cell(3))*psi(1)*psi(2)*(1._wp - psi(3)) @@ -977,7 +977,7 @@ contains term1 = bub_dphidt(bub_id)*intfc_rad(bub_id, 2)**2._wp term2 = intfc_vel(bub_id, 2)*intfc_rad(bub_id, 2)**2._wp - Rbeq = volgas**(1._wp/3._wp) ! surrogate bubble radius + Rbeq = volgas**(1._wp/3._wp) ! surrogate bubble radius aux = dc**3._wp - Rbeq**3._wp term2 = term2/denom term2 = 3._wp/2._wp*term2**2._wp*Rbeq**3._wp*(1._wp - Rbeq/dc)/aux @@ -1002,7 +1002,7 @@ contains integer, intent(in) :: stage integer :: k - if (time_stepper == 1) then ! 1st order TVD RK + if (time_stepper == 1) then ! 1st order TVD RK $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs ! u{1} = u{n} + dt * RHS{n} @@ -1023,7 +1023,7 @@ contains $:GPU_UPDATE(host='[gas_p, gas_mv, intfc_rad, intfc_vel]') call s_write_lag_particles(mytime) end if - else if (time_stepper == 2) then ! 2nd order TVD RK + else if (time_stepper == 2) then ! 2nd order TVD RK if (stage == 1) then $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs @@ -1058,7 +1058,7 @@ contains call s_write_lag_particles(mytime) end if end if - else if (time_stepper == 3) then ! 3rd order TVD RK + else if (time_stepper == 3) then ! 3rd order TVD RK if (stage == 1) then $:GPU_PARALLEL_LOOP(private='[k]') do k = 1, nBubs diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index 257f00d1ac..ea675f904c 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -109,7 +109,7 @@ contains logical :: celloutside integer :: smearGrid, smearGridz - smearGrid = mapCells - (-mapCells) + 1 ! Include the cell that contains the bubble (3+1+3) + smearGrid = mapCells - (-mapCells) + 1 ! Include the cell that contains the bubble (3+1+3) smearGridz = smearGrid if (p == 0) smearGridz = 1 @@ -244,7 +244,7 @@ contains Lz2 = (center(3) - (dzp*(0.5_wp + Nr_count) - lag_params%charwidth/2._wp))**2._wp distance = sqrt((center(1) - nodecoord(1))**2._wp + (center(2) - nodecoord(2))**2._wp + Lz2) func = func + dzp/lag_params%charwidth*exp(-0.5_wp*(distance/stddsv)**2._wp)/(sqrt(2._wp*pi)*stddsv) & - & **(3._wp*(strength_idx + 1._wp)) + & **(3._wp*(strength_idx + 1._wp)) end do end if end if diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index ba0792cd1c..2502fb73dd 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -48,25 +48,25 @@ module m_cbc real(wp), allocatable, dimension(:,:,:,:) :: flux_rsz_vf_l, flux_src_rsz_vf_l $:GPU_DECLARE(create='[flux_rsx_vf_l, flux_src_rsx_vf_l, flux_rsy_vf_l, flux_src_rsy_vf_l, flux_rsz_vf_l, flux_src_rsz_vf_l]') - real(wp), allocatable, dimension(:) :: ds !< Cell-width distribution in the s-direction + real(wp), allocatable, dimension(:) :: ds !< Cell-width distribution in the s-direction ! CBC Coefficients - real(wp), allocatable, dimension(:,:) :: fd_coef_x !< Finite diff. coefficients x-dir - real(wp), allocatable, dimension(:,:) :: fd_coef_y !< Finite diff. coefficients y-dir + real(wp), allocatable, dimension(:,:) :: fd_coef_x !< Finite diff. coefficients x-dir + real(wp), allocatable, dimension(:,:) :: fd_coef_y !< Finite diff. coefficients y-dir !> Finite diff. coefficients z-dir The first dimension identifies the location of a coefficient in the FD formula, while the !! last dimension denotes the location of the CBC. real(wp), allocatable, dimension(:,:) :: fd_coef_z ! Bug with NVHPC when using nullified pointers in a declare create real(wp), pointer, dimension(:, :) :: fd_coef => null() - real(wp), allocatable, dimension(:,:,:) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir - real(wp), allocatable, dimension(:,:,:) :: pi_coef_y !< Polynomial interpolant coefficients in y-dir - real(wp), allocatable, dimension(:,:,:) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir + real(wp), allocatable, dimension(:,:,:) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir + real(wp), allocatable, dimension(:,:,:) :: pi_coef_y !< Polynomial interpolant coefficients in y-dir + real(wp), allocatable, dimension(:,:,:) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir $:GPU_DECLARE(create='[ds, fd_coef_x, fd_coef_y, fd_coef_z, pi_coef_x, pi_coef_y, pi_coef_z]') !! The first dimension of the array identifies the polynomial, the second dimension identifies the position of its coefficients !! and the last dimension denotes the location of the CBC. - type(int_bounds_info) :: is1, is2, is3 !< Indical bounds in the s1-, s2- and s3-directions + type(int_bounds_info) :: is1, is2, is3 !< Indical bounds in the s1-, s2- and s3-directions $:GPU_DECLARE(create='[is1, is2, is3]') integer :: dj @@ -445,7 +445,7 @@ contains subroutine s_associate_cbc_coefficients_pointers(cbc_dir_in, cbc_loc_in) integer, intent(in) :: cbc_dir_in, cbc_loc_in - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator ! Associating CBC Coefficients in x-direction if (cbc_dir_in == 1) then @@ -542,19 +542,19 @@ contains #:endif real(wp), dimension(2) :: Re_cbc real(wp), dimension(3) :: lambda - real(wp) :: rho !< Cell averaged density - real(wp) :: pres !< Cell averaged pressure - real(wp) :: E !< Cell averaged energy - real(wp) :: H !< Cell averaged enthalpy - real(wp) :: gamma !< Cell averaged specific heat ratio - real(wp) :: pi_inf !< Cell averaged liquid stiffness - real(wp) :: qv !< Cell averaged fluid reference energy + real(wp) :: rho !< Cell averaged density + real(wp) :: pres !< Cell averaged pressure + real(wp) :: E !< Cell averaged energy + real(wp) :: H !< Cell averaged enthalpy + real(wp) :: gamma !< Cell averaged specific heat ratio + real(wp) :: pi_inf !< Cell averaged liquid stiffness + real(wp) :: qv !< Cell averaged fluid reference energy real(wp) :: c real(wp) :: Ma real(wp) :: T, sum_Enthalpies real(wp) :: Cv, Cp, e_mix, Mw, R_gas real(wp) :: vel_K_sum, vel_dv_dt_sum - integer :: i, j, k, r !< Generic loop iterators + integer :: i, j, k, r !< Generic loop iterators ! Reshaping of inputted data and association of the FD and PI coefficients, or CBC coefficients, respectively, hinging on ! selected CBC coordinate direction @@ -572,7 +572,7 @@ contains ! PI2 of flux_rs_vf and flux_src_rs_vf at j = 1/2 if (weno_order == 3 .or. dummy) then call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, F_rs${XYZ}$_vf, F_src_rs${XYZ}$_vf, is1, is2, & - & is3, idwbuff(2)%beg, idwbuff(3)%beg) + & is3, idwbuff(2)%beg, idwbuff(3)%beg) $:GPU_PARALLEL_LOOP(private='[i, r, k]', collapse=3) do i = 1, flux_cbc_index @@ -600,7 +600,7 @@ contains ! PI4 of flux_rs_vf and flux_src_rs_vf at j = 1/2, 3/2 if (weno_order == 5 .or. dummy) then call s_convert_primitive_to_flux_variables(q_prim_rs${XYZ}$_vf, F_rs${XYZ}$_vf, F_src_rs${XYZ}$_vf, is1, is2, & - & is3, idwbuff(2)%beg, idwbuff(3)%beg) + & is3, idwbuff(2)%beg, idwbuff(3)%beg) $:GPU_PARALLEL_LOOP(private='[i, j, r, k]', collapse=4) do i = 1, flux_cbc_index @@ -771,7 +771,7 @@ contains else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_BUFFER) & & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_BUFFER)) then call s_compute_nonreflecting_subsonic_buffer_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds, dYs_ds) + & dvel_ds, dadv_ds, dYs_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_INFLOW) & & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_INFLOW)) then call s_compute_nonreflecting_subsonic_inflow_L(lambda, L, rho, c, dpres_ds, dvel_ds) @@ -799,7 +799,7 @@ contains else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_NR_SUB_OUTFLOW) & & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_NR_SUB_OUTFLOW)) then call s_compute_nonreflecting_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds, dYs_ds) + & dvel_ds, dadv_ds, dYs_ds) ! Add GRCBC for Subsonic Outflow (Pressure) if (bc_${XYZ}$%grcbc_out) then L(advxe) = c*(1._wp - Ma)*(pres - pres_out(${CBC_DIR}$))/Del_out(${CBC_DIR}$) @@ -813,11 +813,11 @@ contains else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_FF_SUB_OUTFLOW) & & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_FF_SUB_OUTFLOW)) then call s_compute_force_free_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, dvel_ds, & - & dadv_ds) + & dadv_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_CP_SUB_OUTFLOW) & & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_CP_SUB_OUTFLOW)) then call s_compute_constant_pressure_subsonic_outflow_L(lambda, L, rho, c, mf, dalpha_rho_ds, dpres_ds, & - & dvel_ds, dadv_ds) + & dvel_ds, dadv_ds) else if ((cbc_loc == -1 .and. bc${XYZ}$b == BC_CHAR_SUP_INFLOW) & & .or. (cbc_loc == 1 .and. bc${XYZ}$e == BC_CHAR_SUP_INFLOW)) then call s_compute_supersonic_inflow_L(L) @@ -862,7 +862,7 @@ contains if (cyl_coord .and. cbc_dir == 2 .and. cbc_loc == 1) then $:GPU_LOOP(parallelism='[seq]') do i = 1, advxe - E_idx - dadv_dt(i) = -L(momxe + i) ! + adv_local(i) * vel(dir_idx(1))/y_cc(n) + dadv_dt(i) = -L(momxe + i) ! + adv_local(i) * vel(dir_idx(1))/y_cc(n) end do else $:GPU_LOOP(parallelism='[seq]') @@ -983,7 +983,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(in) :: flux_vf, flux_src_vf type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: i, j, k, r !< Generic loop iterators + integer :: i, j, k, r !< Generic loop iterators ! Configuring the coordinate direction indexes and flags ! Determining the indicial shift based on CBC location @@ -1236,7 +1236,7 @@ contains subroutine s_finalize_cbc(flux_vf, flux_src_vf) type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf - integer :: i, j, k, r !< Generic loop iterators + integer :: i, j, k, r !< Generic loop iterators ! Determining the indicial shift based on CBC location dj = max(0, cbc_loc) diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 4a24103714..c4ccecd7d8 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -51,7 +51,7 @@ contains !> Checks constraints on WENO scheme parameters impure subroutine s_check_inputs_weno - character(len=5) :: numStr !< for int to string conversion + character(len=5) :: numStr !< for int to string conversion call s_int_to_str(num_stcls_min*weno_order, numStr) @:PROHIBIT(m + 1 < num_stcls_min*weno_order, & @@ -68,7 +68,7 @@ contains !> @brief Validates that the grid resolution is sufficient for the MUSCL reconstruction order. impure subroutine s_check_inputs_muscl - character(len=5) :: numStr !< for int to string conversion + character(len=5) :: numStr !< for int to string conversion call s_int_to_str(num_stcls_min*muscl_order, numStr) @:PROHIBIT(m + 1 < num_stcls_min*muscl_order, & diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index abac4af1a9..af31d30fe9 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -81,7 +81,7 @@ contains real(wp) :: radius, dist real(wp), dimension(2) :: center real(wp), dimension(3) :: dist_vec - integer :: i, j, ib_patch_id !< Loop index variables + integer :: i, j, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -111,10 +111,10 @@ contains real(wp) :: dist, global_dist integer :: global_id real(wp), dimension(3) :: dist_vec - real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame real(wp), dimension(1:2) :: center real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - integer :: i, j, k, ib_patch_id !< Loop index variables + integer :: i, j, k, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -125,9 +125,9 @@ contains rotation(:,:) = patch_ib(ib_patch_id)%rotation_matrix(:,:) offset(:) = patch_ib(ib_patch_id)%centroid_offset(:) - xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] ! get coordinate frame centered on IB - xy_local = matmul(inverse_rotation, xy_local) ! rotate the frame into the IB's coordinate - xy_local = xy_local - offset ! airfoils are a patch that require a centroid offset + xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] ! get coordinate frame centered on IB + xy_local = matmul(inverse_rotation, xy_local) ! rotate the frame into the IB's coordinate + xy_local = xy_local - offset ! airfoils are a patch that require a centroid offset if (xy_local(2) >= 0._wp) then ! finds the location on the airfoil grid with the minimum distance (closest) @@ -176,7 +176,7 @@ contains if (f_approx_equal(dist, 0._wp)) then gp%levelset_norm = 0._wp else - gp%levelset_norm = matmul(rotation, dist_vec(:))/dist ! convert the normal vector back to global grid coordinates + gp%levelset_norm = matmul(rotation, dist_vec(:))/dist ! convert the normal vector back to global grid coordinates end if end subroutine s_airfoil_levelset @@ -192,10 +192,10 @@ contains integer :: global_id real(wp) :: lz, z_max, z_min real(wp), dimension(3) :: dist_vec - real(wp), dimension(1:3) :: xyz_local, center, offset, normal !< x, y, z coordinates in local IB frame + real(wp), dimension(1:3) :: xyz_local, center, offset, normal !< x, y, z coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation real(wp) :: length_z - integer :: i, j, k, l, ib_patch_id !< Loop index variables + integer :: i, j, k, l, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -213,8 +213,8 @@ contains z_min = -lz/2 xyz_local = [x_cc(i), y_cc(j), z_cc(l)] - center - xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates - xyz_local = xyz_local - offset ! airfoils are a patch that require a centroid offset + xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates + xyz_local = xyz_local - offset ! airfoils are a patch that require a centroid offset if (xyz_local(2) >= 0._wp) then do k = 1, Np @@ -290,12 +290,12 @@ contains real(wp) :: min_dist real(wp) :: side_dists(4) real(wp) :: length_x, length_y - real(wp), dimension(1:3) :: xy_local, dist_vec !< x and y coordinates in local IB frame - real(wp), dimension(2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xy_local, dist_vec !< x and y coordinates in local IB frame + real(wp), dimension(2) :: center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - integer :: i, j, k !< Loop index variables - integer :: idx !< Shortest path direction indicator - integer :: ib_patch_id !< patch ID + integer :: i, j, k !< Loop index variables + integer :: idx !< Shortest path direction indicator + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -355,15 +355,15 @@ contains $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - real(wp) :: ellipse_coeffs(2) ! a and b in the ellipse equation - real(wp) :: quadratic_coeffs(3) ! A, B, C in the quadratic equation to compute levelset + real(wp) :: ellipse_coeffs(2) ! a and b in the ellipse equation + real(wp) :: quadratic_coeffs(3) ! A, B, C in the quadratic equation to compute levelset real(wp) :: length_x, length_y - real(wp), dimension(1:3) :: xy_local, normal_vector !< x and y coordinates in local IB frame - real(wp), dimension(2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xy_local, normal_vector !< x and y coordinates in local IB frame + real(wp), dimension(2) :: center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - integer :: i, j, k !< Loop index variables - integer :: idx !< Shortest path direction indicator - integer :: ib_patch_id !< patch ID + integer :: i, j, k !< Loop index variables + integer :: idx !< Shortest path direction indicator + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -383,9 +383,9 @@ contains normal_vector = xy_local normal_vector(2) = normal_vector(2)*(ellipse_coeffs(1)/ellipse_coeffs(2)) & - & **2._wp ! get the normal direction via the coordinate transformation method - normal_vector = normal_vector/sqrt(dot_product(normal_vector, normal_vector)) ! normalize the vector - gp%levelset_norm = matmul(rotation, normal_vector) ! save after rotating the vector to the global frame + & **2._wp ! get the normal direction via the coordinate transformation method + normal_vector = normal_vector/sqrt(dot_product(normal_vector, normal_vector)) ! normalize the vector + gp%levelset_norm = matmul(rotation, normal_vector) ! save after rotating the vector to the global frame ! use the normal vector to set up the quadratic equation for the levelset, using A, B, and C in indices 1, 2, and 3 quadratic_coeffs(1) = (normal_vector(1)/ellipse_coeffs(1))**2 + (normal_vector(2)/ellipse_coeffs(2))**2 @@ -410,10 +410,10 @@ contains real(wp) :: dist_left, dist_right, dist_bottom, dist_top, dist_back, dist_front real(wp), dimension(3) :: center real(wp) :: length_x, length_y, length_z - real(wp), dimension(1:3) :: xyz_local, dist_vec !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xyz_local, dist_vec !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation - integer :: i, j, k !< Loop index variables - integer :: ib_patch_id !< patch ID + integer :: i, j, k !< Loop index variables + integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -437,8 +437,8 @@ contains Front = length_z/2 Back = -length_z/2 - xyz_local = [x_cc(i), y_cc(j), z_cc(k)] - center ! get coordinate frame centered on IB - xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinate + xyz_local = [x_cc(i), y_cc(j), z_cc(k)] - center ! get coordinate frame centered on IB + xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinate dist_left = Left - xyz_local(1) dist_right = xyz_local(1) - Right @@ -494,7 +494,7 @@ contains type(ghost_point), intent(inout) :: gp real(wp) :: radius, dist real(wp), dimension(3) :: dist_vec, center, periodicity - integer :: i, j, k, ib_patch_id !< Loop index variables + integer :: i, j, k, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) j = gp%loc(2) @@ -533,9 +533,9 @@ contains real(wp), dimension(3) :: dist_sides_vec, dist_surface_vec, length real(wp), dimension(2) :: boundary real(wp) :: dist_side, dist_surface, side_pos - integer :: i, j, k !< Loop index variables - integer :: ib_patch_id !< patch ID - real(wp), dimension(1:3) :: xyz_local, center !< x and y coordinates in local IB frame + integer :: i, j, k !< Loop index variables + integer :: ib_patch_id !< patch ID + real(wp), dimension(1:3) :: xyz_local, center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation ib_patch_id = gp%ib_patch_id @@ -571,8 +571,8 @@ contains dist_surface_vec = (/1, 1, 0/) end if - xyz_local = [x_cc(i), y_cc(j), z_cc(k)] - center ! get coordinate frame centered on IB - xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates + xyz_local = [x_cc(i), y_cc(j), z_cc(k)] - center ! get coordinate frame centered on IB + xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates ! get distance to flat edge of cylinder side_pos = dot_product(xyz_local, dist_sides_vec) @@ -606,7 +606,7 @@ contains type(ghost_point), intent(inout) :: gp integer :: i, j, k, patch_id, boundary_edge_count, total_vertices real(wp), dimension(1:3) :: center, xyz_local - real(wp) :: normals(1:3) !< Boundary normal buffer + real(wp) :: normals(1:3) !< Boundary normal buffer real(wp) :: distance real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index c1bf848ef9..de7b5259d0 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -22,34 +22,34 @@ module m_data_output implicit none - private; + private public :: s_initialize_data_output_module, s_open_run_time_information_file, s_open_com_files, s_open_probe_files, & & s_open_ib_state_file, s_write_run_time_information, s_write_data_files, s_write_serial_data_files, & & s_write_parallel_data_files, s_write_ib_data_file, s_write_com_files, s_write_probe_files, s_write_ib_state_file, & & s_close_run_time_information_file, s_close_com_files, s_close_probe_files, s_close_ib_state_file, & & s_finalize_data_output_module - integer :: ib_state_unit = -1 !< I/O unit for IB state binary file - real(wp), allocatable, dimension(:,:,:) :: icfl_sf !< ICFL stability criterion - real(wp), allocatable, dimension(:,:,:) :: vcfl_sf !< VCFL stability criterion - real(wp), allocatable, dimension(:,:,:) :: ccfl_sf !< CCFL stability criterion - real(wp), allocatable, dimension(:,:,:) :: Rc_sf !< Rc stability criterion + integer :: ib_state_unit = -1 !< I/O unit for IB state binary file + real(wp), allocatable, dimension(:,:,:) :: icfl_sf !< ICFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: vcfl_sf !< VCFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: ccfl_sf !< CCFL stability criterion + real(wp), allocatable, dimension(:,:,:) :: Rc_sf !< Rc stability criterion real(wp), public, allocatable, dimension(:,:) :: c_mass $:GPU_DECLARE(create='[icfl_sf, vcfl_sf, ccfl_sf, Rc_sf, c_mass]') - real(wp) :: icfl_max_loc, icfl_max_glb !< ICFL stability extrema on local and global grids - real(wp) :: vcfl_max_loc, vcfl_max_glb !< VCFL stability extrema on local and global grids - real(wp) :: ccfl_max_loc, ccfl_max_glb !< CCFL stability extrema on local and global grids - real(wp) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids + real(wp) :: icfl_max_loc, icfl_max_glb !< ICFL stability extrema on local and global grids + real(wp) :: vcfl_max_loc, vcfl_max_glb !< VCFL stability extrema on local and global grids + real(wp) :: ccfl_max_loc, ccfl_max_glb !< CCFL stability extrema on local and global grids + real(wp) :: Rc_min_loc, Rc_min_glb !< Rc stability extrema on local and global grids $:GPU_DECLARE(create='[icfl_max_loc, icfl_max_glb, vcfl_max_loc, vcfl_max_glb]') $:GPU_DECLARE(create='[ccfl_max_loc, ccfl_max_glb, Rc_min_loc, Rc_min_glb]') !> @name ICFL, VCFL, CCFL and Rc stability criteria extrema over all the time-steps !> @{ - real(wp) :: icfl_max !< ICFL criterion maximum - real(wp) :: vcfl_max !< VCFL criterion maximum - real(wp) :: ccfl_max !< CCFL criterion maximum - real(wp) :: Rc_min !< Rc criterion maximum + real(wp) :: icfl_max !< ICFL criterion maximum + real(wp) :: vcfl_max !< VCFL criterion maximum + real(wp) :: ccfl_max !< CCFL criterion maximum + real(wp) :: Rc_min !< Rc criterion maximum !> @} type(scalar_field), allocatable, dimension(:) :: q_cons_temp_ds @@ -85,9 +85,9 @@ contains !! which will be written at every time-step. impure subroutine s_open_run_time_information_file - character(LEN=name_len), parameter :: file_name = 'run_time.inf' !< Name of the run-time information file - character(LEN=path_len + name_len) :: file_path !< Relative path to a file in the case directory - character(LEN=8) :: file_date !< Creation date of the run-time information file + character(LEN=name_len), parameter :: file_name = 'run_time.inf' !< Name of the run-time information file + character(LEN=path_len + name_len) :: file_path !< Relative path to a file in the case directory + character(LEN=8) :: file_date !< Creation date of the run-time information file file_path = trim(case_dir) // '/' // trim(file_name) @@ -112,15 +112,15 @@ contains write (3, '(13X,A10,13X,A16)', advance="no") trim('VCFL Max'), trim('Rc Min') end if - write (3, *) ! new line + write (3, *) ! new line end subroutine s_open_run_time_information_file !> This opens a formatted data file where the root processor can write out the CoM information impure subroutine s_open_com_files() - character(len=path_len + 3*name_len) :: file_path !< Relative path to the CoM file in the case directory - integer :: i !< Generic loop iterator + character(len=path_len + 3*name_len) :: file_path !< Relative path to the CoM file in the case directory + integer :: i !< Generic loop iterator do i = 1, num_fluids write (file_path, '(A,I0,A)') '/fluid', i, '_com.dat' @@ -144,8 +144,8 @@ contains !> This opens a formatted data file where the root processor can write out flow probe information impure subroutine s_open_probe_files - character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the probe data file in the case directory - integer :: i !< Generic loop iterator + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the probe data file in the case directory + integer :: i !< Generic loop iterator logical :: file_exist do i = 1, num_probes @@ -193,23 +193,23 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf integer, intent(in) :: t_step - real(wp) :: rho !< Cell-avg. density + real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction - real(wp), dimension(3) :: vel !< Cell-avg. velocity + real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction + real(wp), dimension(3) :: vel !< Cell-avg. velocity #:else - real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction - real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity + real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction + real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity #:endif - real(wp) :: vel_sum !< Cell-avg. velocity sum - real(wp) :: pres !< Cell-avg. pressure - real(wp) :: gamma !< Cell-avg. sp. heat ratio - real(wp) :: pi_inf !< Cell-avg. liquid stiffness function - real(wp) :: qv !< Cell-avg. internal energy reference value - real(wp) :: c !< Cell-avg. sound speed - real(wp) :: H !< Cell-avg. enthalpy - real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers + real(wp) :: vel_sum !< Cell-avg. velocity sum + real(wp) :: pres !< Cell-avg. pressure + real(wp) :: gamma !< Cell-avg. sp. heat ratio + real(wp) :: pi_inf !< Cell-avg. liquid stiffness function + real(wp) :: qv !< Cell-avg. internal energy reference value + real(wp) :: c !< Cell-avg. sound speed + real(wp) :: H !< Cell-avg. enthalpy + real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers integer :: j, k, l ! Computing Stability Criteria at Current Time-step @@ -259,7 +259,7 @@ contains if (num_procs > 1) then call s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & - & Rc_min_glb) + & Rc_min_glb) else icfl_max_glb = icfl_max_loc if (viscous) vcfl_max_glb = vcfl_max_loc @@ -280,7 +280,7 @@ contains write (3, '(13X,F10.6,13X,ES16.6)', advance="no") vcfl_max_glb, Rc_min_glb end if - write (3, *) ! new line + write (3, *) ! new line if (.not. f_approx_equal(icfl_max_glb, icfl_max_glb)) then call s_mpi_abort('ICFL is NaN. Exiting.') @@ -318,12 +318,12 @@ contains integer, intent(in) :: t_step type(scalar_field), intent(inout), optional :: beta type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type - character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the current time-step directory - character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files - logical :: file_exist !< Logical used to check existence of current time-step directory + character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the current time-step directory + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files + logical :: file_exist !< Logical used to check existence of current time-step directory character(LEN=15) :: FMT integer :: i, j, k, l, r - real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params + real(wp) :: gamma, lit_gamma, pi_inf, qv !< Temporary EOS params write (t_step_dir, '(A,I0,A,I0)') trim(case_dir) // '/p_all' write (t_step_dir, '(a,i0,a,i0)') trim(case_dir) // '/p_all/p', proc_rank, '/', t_step @@ -688,12 +688,12 @@ contains character(LEN=path_len + 2*name_len) :: file_loc logical :: file_exist, dir_check character(len=10) :: t_step_string - integer :: i !< Generic loop iterator - integer :: alt_sys !< Altered system size for the lagrangian subgrid bubble model + integer :: i !< Generic loop iterator + integer :: alt_sys !< Altered system size for the lagrangian subgrid bubble model ! Down sampling variables integer :: m_ds, n_ds, p_ds integer :: m_glb_ds, n_glb_ds, p_glb_ds - integer :: m_glb_save, n_glb_save, p_glb_save ! Global save size + integer :: m_glb_save, n_glb_save, p_glb_save ! Global save size if (down_sample) then call s_downsample_data(q_cons_vf, q_cons_temp_ds, m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) @@ -774,13 +774,13 @@ contains end if else if (down_sample) then - do i = 1, sys_size ! TODO: check if correct (sys_size + do i = 1, sys_size ! TODO: check if sys_size is correct var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, q_cons_temp_ds(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) end do else - do i = 1, sys_size ! TODO: check if correct (sys_size + do i = 1, sys_size ! TODO: check if sys_size is correct var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_WRITE_ALL(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) @@ -836,7 +836,7 @@ contains end do end if else - do i = 1, sys_size ! TODO: check if correct (sys_size + do i = 1, sys_size ! TODO: check if sys_size is correct var_MOK = int(i, MPI_OFFSET_KIND) disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) @@ -952,8 +952,8 @@ contains integer, intent(in) :: t_step real(wp), dimension(num_fluids, 5), intent(in) :: c_mass_in - integer :: i !< Generic loop iterator - real(wp) :: nondim_time !< Non-dimensional time + integer :: i !< Generic loop iterator + real(wp) :: nondim_time !< Non-dimensional time if (t_step_old /= dflt_int) then nondim_time = real(t_step + t_step_old, wp)*dt @@ -1020,12 +1020,12 @@ contains real(wp) :: G_local real(wp) :: dyn_p, T real(wp) :: damage_state - integer :: i, j, k, l, s, d !< Generic loop iterator - real(wp) :: nondim_time !< Non-dimensional time - real(wp) :: tmp !< Temporary variable to store quantity for mpi_allreduce - integer :: npts !< Number of included integral points - real(wp) :: rad, thickness !< For integral quantities - logical :: trigger !< For integral quantities + integer :: i, j, k, l, s, d !< Generic loop iterator + real(wp) :: nondim_time !< Non-dimensional time + real(wp) :: tmp !< Temporary variable to store quantity for mpi_allreduce + integer :: npts !< Number of included integral points + real(wp) :: rad, thickness !< For integral quantities + logical :: trigger !< For integral quantities real(wp) :: rhoYks(1:num_species) T = dflt_T_guess @@ -1074,7 +1074,7 @@ contains if (distx(s) < 0._wp) distx(s) = 1000._wp end do j = minloc(distx, 1) - if (j == 1) j = 2 ! Pick first point if probe is at edge + if (j == 1) j = 2 ! Pick first point if probe is at edge k = 0 l = 0 @@ -1189,8 +1189,8 @@ contains end do j = minloc(distx, 1) k = minloc(disty, 1) - if (j == 1) j = 2 ! Pick first point if probe is at edge - if (k == 1) k = 2 ! Pick first point if probe is at edge + if (j == 1) j = 2 ! Pick first point if probe is at edge + if (k == 1) k = 2 ! Pick first point if probe is at edge l = 0 ! Computing/Sharing necessary state variables @@ -1270,9 +1270,9 @@ contains j = minloc(distx, 1) k = minloc(disty, 1) l = minloc(distz, 1) - if (j == 1) j = 2 ! Pick first point if probe is at edge - if (k == 1) k = 2 ! Pick first point if probe is at edge - if (l == 1) l = 2 ! Pick first point if probe is at edge + if (j == 1) j = 2 ! Pick first point if probe is at edge + if (k == 1) k = 2 ! Pick first point if probe is at edge + if (l == 1) l = 2 ! Pick first point if probe is at edge ! Computing/Sharing necessary state variables call s_convert_to_mixture_variables(q_cons_vf, j - 2, k - 2, l - 2, rho, gamma, pi_inf, qv, Re, & @@ -1525,7 +1525,7 @@ contains !! and the simulation run-time. impure subroutine s_close_run_time_information_file - real(wp) :: run_time !< Run-time of the simulation + real(wp) :: run_time !< Run-time of the simulation write (3, '(A)') ' ' write (3, '(A)') '' @@ -1546,7 +1546,7 @@ contains !> Closes communication files impure subroutine s_close_com_files() - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator do i = 1, num_fluids close (i + 120) @@ -1557,7 +1557,7 @@ contains !> Closes probe files impure subroutine s_close_probe_files - integer :: i !< Generic loop iterator + integer :: i !< Generic loop iterator do i = 1, num_probes close (i + 30) diff --git a/src/simulation/m_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index d7f3701878..61477a4f9e 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -106,7 +106,7 @@ contains integer, intent(in) :: t_step type(scalar_field), dimension(:), intent(inout) :: q_cons_vf type(vector_field), dimension(:), intent(inout) :: q_prim_ts1, q_prim_ts2 - integer :: i, j, k !< Generic loop iterators + integer :: i, j, k !< Generic loop iterators if (probe_wrt) then call s_derive_acceleration_component(1, q_prim_ts1(1)%vf, q_prim_ts1(2)%vf, q_prim_ts2(1)%vf, q_prim_ts2(2)%vf, x_accel) @@ -163,7 +163,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf2 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf3 real(wp), dimension(0:m, 0:n, 0:p), intent(out) :: q_sf - integer :: j, k, l, r !< Generic loop iterators + integer :: j, k, l, r !< Generic loop iterators ! Computing the acceleration component in the x-coordinate direction if (i == 1) then @@ -357,21 +357,21 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_vf real(wp), dimension(1:num_fluids, 1:5), intent(inout) :: c_m - integer :: i, j, k, l !< Generic loop iterators - real(wp) :: tmp, tmp_out !< Temporary variable to store quantity for mpi_allreduce - real(wp) :: dV !< Discrete cell volume + integer :: i, j, k, l !< Generic loop iterators + real(wp) :: tmp, tmp_out !< Temporary variable to store quantity for mpi_allreduce + real(wp) :: dV !< Discrete cell volume c_m(:,:) = 0.0_wp $:GPU_UPDATE(device='[c_m]') - if (n == 0) then ! 1D simulation + if (n == 0) then ! 1D simulation $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, dV]') - do l = 0, p ! Loop over grid + do l = 0, p ! Loop over grid do k = 0, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids ! Loop over individual fluids + do i = 1, num_fluids ! Loop over individual fluids dV = dx(j) ! Mass $:GPU_ATOMIC(atomic='update') @@ -387,13 +387,13 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - else if (p == 0) then ! 2D simulation + else if (p == 0) then ! 2D simulation $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, dV]') - do l = 0, p ! Loop over grid + do l = 0, p ! Loop over grid do k = 0, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids ! Loop over individual fluids + do i = 1, num_fluids ! Loop over individual fluids dV = dx(j)*dy(k) ! Mass $:GPU_ATOMIC(atomic='update') @@ -412,13 +412,13 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - else ! 3D simulation + else ! 3D simulation $:GPU_PARALLEL_LOOP(collapse=3,private='[j, k, l, dV]') - do l = 0, p ! Loop over grid + do l = 0, p ! Loop over grid do k = 0, n do j = 0, m $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids ! Loop over individual fluids + do i = 1, num_fluids ! Loop over individual fluids dV = dx(j)*dy(k)*dz(l) ! Mass $:GPU_ATOMIC(atomic='update') @@ -444,8 +444,8 @@ contains $:GPU_UPDATE(host='[c_m]') - if (n == 0) then ! 1D simulation - do i = 1, num_fluids ! Loop over individual fluids + if (n == 0) then ! 1D simulation + do i = 1, num_fluids ! Loop over individual fluids ! Sum all components across all processors using MPI_ALLREDUCE if (num_procs > 1) then tmp = c_m(i, 1) @@ -461,8 +461,8 @@ contains ! Compute quotients c_m(i, 2) = c_m(i, 2)/c_m(i, 1) end do - else if (p == 0) then ! 2D simulation - do i = 1, num_fluids ! Loop over individual fluids + else if (p == 0) then ! 2D simulation + do i = 1, num_fluids ! Loop over individual fluids ! Sum all components across all processors using MPI_ALLREDUCE if (num_procs > 1) then tmp = c_m(i, 1) @@ -482,8 +482,8 @@ contains c_m(i, 2) = c_m(i, 2)/c_m(i, 1) c_m(i, 3) = c_m(i, 3)/c_m(i, 1) end do - else ! 3D simulation - do i = 1, num_fluids ! Loop over individual fluids + else ! 3D simulation + do i = 1, num_fluids ! Loop over individual fluids ! Sum all components across all processors using MPI_ALLREDUCE if (num_procs > 1) then tmp = c_m(i, 1) diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 395cff99cb..a89e626bf6 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -31,9 +31,9 @@ module m_fftw type(c_ptr) :: fwd_plan, bwd_plan type(c_ptr) :: fftw_real_data, fftw_cmplx_data, fftw_fltr_cmplx_data integer :: real_size, cmplx_size, x_size, batch_size, Nfq - real(c_double), pointer :: data_real(:) !< Real data - complex(c_double_complex), pointer :: data_cmplx(:) !< Complex data in Fourier space - complex(c_double_complex), pointer :: data_fltr_cmplx(:) !< Filtered complex data in Fourier space + real(c_double), pointer :: data_real(:) !< Real data + complex(c_double_complex), pointer :: data_cmplx(:) !< Complex data in Fourier space + complex(c_double_complex), pointer :: data_fltr_cmplx(:) !< Filtered complex data in Fourier space #if defined(MFC_GPU) $:GPU_DECLARE(create='[real_size, cmplx_size, x_size, batch_size, Nfq]') @@ -62,7 +62,7 @@ contains !! the Fourier filter in the azimuthal direction. impure subroutine s_initialize_fftw_module - integer :: ierr !< Generic flag used to identify and report GPU errors + integer :: ierr !< Generic flag used to identify and report GPU errors ! Size of input array going into DFT real_size = p + 1 @@ -76,7 +76,7 @@ contains rank = 1; istride = 1; ostride = 1 allocate (gpu_fft_size(1:rank), iembed(1:rank), oembed(1:rank)) - gpu_fft_size(1) = real_size; + gpu_fft_size(1) = real_size iembed(1) = 0 oembed(1) = 0 $:GPU_ENTER_DATA(copyin='[real_size, cmplx_size, x_size, sys_size, batch_size, Nfq]') @@ -122,8 +122,8 @@ contains impure subroutine s_apply_fourier_filter(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer :: i, j, k, l !< Generic loop iterators - integer :: ierr !< Generic flag used to identify and report GPU errors + integer :: i, j, k, l !< Generic loop iterators + integer :: ierr !< Generic flag used to identify and report GPU errors ! Restrict filter to processors that have cells adjacent to axis if (bc_y%beg >= 0) return @@ -294,7 +294,7 @@ contains impure subroutine s_finalize_fftw_module #if defined(MFC_GPU) - integer :: ierr !< Generic flag used to identify and report GPU errors + integer :: ierr !< Generic flag used to identify and report GPU errors @:DEALLOCATE(data_real_gpu, data_fltr_cmplx_gpu, data_cmplx_gpu) #if defined(__PGI) diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 8ed4845d29..c3856e605f 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -9,7 +9,7 @@ module m_global_parameters #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_derived_types @@ -22,12 +22,12 @@ module m_global_parameters real(wp) :: wall_time_avg = 0 ! Logistics - integer :: num_procs !< Number of processors - character(LEN=path_len) :: case_dir !< Case folder location - logical :: run_time_info !< Run-time output flag - integer :: t_step_old !< Existing IC/grid folder + integer :: num_procs !< Number of processors + character(LEN=path_len) :: case_dir !< Case folder location + logical :: run_time_info !< Run-time output flag + integer :: t_step_old !< Existing IC/grid folder ! Computational Domain Parameters - integer :: proc_rank !< Rank of the local processor + integer :: proc_rank !< Rank of the local processor !> @name Number of cells in the x-, y- and z-directions, respectively !> @{ integer :: m, n, p @@ -64,7 +64,7 @@ module m_global_parameters real(wp), target, allocatable, dimension(:) :: dx, dy, dz !> @} - real(wp) :: dt !< Size of the time-step + real(wp) :: dt !< Size of the time-step $:GPU_DECLARE(create='[x_cb, y_cb, z_cb, x_cc, y_cc, z_cc, dx, dy, dz, dt, m, n, p]') !> @name Starting time-step iteration, stopping time-step iteration and the number of time-step iterations between successive @@ -81,103 +81,103 @@ module m_global_parameters $:GPU_DECLARE(create='[cfl_target]') logical :: cfl_adap_dt, cfl_const_dt, cfl_dt - integer :: t_step_print !< Number of time-steps between printouts + integer :: t_step_print !< Number of time-steps between printouts ! Simulation Algorithm Parameters - integer :: model_eqns !< Multicomponent flow model + integer :: model_eqns !< Multicomponent flow model #:if MFC_CASE_OPTIMIZATION - integer, parameter :: num_dims = ${num_dims}$ !< Number of spatial dimensions - integer, parameter :: num_vels = ${num_vels}$ !< Number of velocity components (different from num_dims for mhd) + integer, parameter :: num_dims = ${num_dims}$ !< Number of spatial dimensions + integer, parameter :: num_vels = ${num_vels}$ !< Number of velocity components (different from num_dims for mhd) #:else - integer :: num_dims !< Number of spatial dimensions - integer :: num_vels !< Number of velocity components (different from num_dims for mhd) + integer :: num_dims !< Number of spatial dimensions + integer :: num_vels !< Number of velocity components (different from num_dims for mhd) #:endif - logical :: mpp_lim !< Mixture physical parameters (MPP) limits - integer :: time_stepper !< Time-stepper algorithm + logical :: mpp_lim !< Mixture physical parameters (MPP) limits + integer :: time_stepper !< Time-stepper algorithm logical :: prim_vars_wrt #:if MFC_CASE_OPTIMIZATION - integer, parameter :: recon_type = ${recon_type}$ !< Reconstruction type - integer, parameter :: weno_polyn = ${weno_polyn}$ !< Degree of the WENO polynomials (polyn) - integer, parameter :: muscl_polyn = ${muscl_polyn}$ !< Degree of the MUSCL polynomials (polyn) - integer, parameter :: weno_order = ${weno_order}$ !< Order of the WENO reconstruction - integer, parameter :: muscl_order = ${muscl_order}$ !< Order of the MUSCL order + integer, parameter :: recon_type = ${recon_type}$ !< Reconstruction type + integer, parameter :: weno_polyn = ${weno_polyn}$ !< Degree of the WENO polynomials (polyn) + integer, parameter :: muscl_polyn = ${muscl_polyn}$ !< Degree of the MUSCL polynomials (polyn) + integer, parameter :: weno_order = ${weno_order}$ !< Order of the WENO reconstruction + integer, parameter :: muscl_order = ${muscl_order}$ !< Order of the MUSCL order !> Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) integer, parameter :: weno_num_stencils = ${weno_num_stencils}$ - integer, parameter :: muscl_lim = ${muscl_lim}$ !< MUSCL Limiter - integer, parameter :: num_fluids = ${num_fluids}$ !< number of fluids in the simulation - logical, parameter :: wenojs = (${wenojs}$ /= 0) !< WENO-JS (default) - logical, parameter :: mapped_weno = (${mapped_weno}$ /= 0) !< WENO-M (WENO with mapping of nonlinear weights) - logical, parameter :: wenoz = (${wenoz}$ /= 0) !< WENO-Z - logical, parameter :: teno = (${teno}$ /= 0) !< TENO (Targeted ENO) - real(wp), parameter :: wenoz_q = ${wenoz_q}$ !< Power constant for WENO-Z - logical, parameter :: mhd = (${mhd}$ /= 0) !< Magnetohydrodynamics - logical, parameter :: relativity = (${relativity}$ /= 0) !< Relativity (only for MHD) - integer, parameter :: igr_iter_solver = ${igr_iter_solver}$ !< IGR elliptic solver - integer, parameter :: igr_order = ${igr_order}$ !< Reconstruction order for IGR - logical, parameter :: igr = (${igr}$ /= 0) !< use information geometric regularization - logical, parameter :: igr_pres_lim = (${igr_pres_lim}$ /= 0) !< Limit to positive pressures for IGR - logical, parameter :: viscous = (${viscous}$ /= 0) !< Viscous effects + integer, parameter :: muscl_lim = ${muscl_lim}$ !< MUSCL Limiter + integer, parameter :: num_fluids = ${num_fluids}$ !< number of fluids in the simulation + logical, parameter :: wenojs = (${wenojs}$ /= 0) !< WENO-JS (default) + logical, parameter :: mapped_weno = (${mapped_weno}$ /= 0) !< WENO-M (WENO with mapping of nonlinear weights) + logical, parameter :: wenoz = (${wenoz}$ /= 0) !< WENO-Z + logical, parameter :: teno = (${teno}$ /= 0) !< TENO (Targeted ENO) + real(wp), parameter :: wenoz_q = ${wenoz_q}$ !< Power constant for WENO-Z + logical, parameter :: mhd = (${mhd}$ /= 0) !< Magnetohydrodynamics + logical, parameter :: relativity = (${relativity}$ /= 0) !< Relativity (only for MHD) + integer, parameter :: igr_iter_solver = ${igr_iter_solver}$ !< IGR elliptic solver + integer, parameter :: igr_order = ${igr_order}$ !< Reconstruction order for IGR + logical, parameter :: igr = (${igr}$ /= 0) !< use information geometric regularization + logical, parameter :: igr_pres_lim = (${igr_pres_lim}$ /= 0) !< Limit to positive pressures for IGR + logical, parameter :: viscous = (${viscous}$ /= 0) !< Viscous effects #:else - integer :: recon_type !< Reconstruction Type - integer :: weno_polyn !< Degree of the WENO polynomials (polyn) - integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn)i - integer :: weno_order !< Order of the WENO reconstruction - integer :: muscl_order !< Order of the MUSCL reconstruction - integer :: weno_num_stencils !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) - integer :: muscl_lim !< MUSCL Limiter - integer :: num_fluids !< number of fluids in the simulation - logical :: wenojs !< WENO-JS (default) - logical :: mapped_weno !< WENO-M (WENO with mapping of nonlinear weights) - logical :: wenoz !< WENO-Z - logical :: teno !< TENO (Targeted ENO) - real(wp) :: wenoz_q !< Power constant for WENO-Z - logical :: mhd !< Magnetohydrodynamics - logical :: relativity !< Relativity (only for MHD) - integer :: igr_iter_solver !< IGR elliptic solver - integer :: igr_order !< Reconstruction order for IGR - logical :: igr !< Use information geometric regularization - logical :: igr_pres_lim !< Limit to positive pressures for IGR - logical :: viscous !< Viscous effects + integer :: recon_type !< Reconstruction Type + integer :: weno_polyn !< Degree of the WENO polynomials (polyn) + integer :: muscl_polyn !< Degree of the MUSCL polynomials (polyn)i + integer :: weno_order !< Order of the WENO reconstruction + integer :: muscl_order !< Order of the MUSCL reconstruction + integer :: weno_num_stencils !< Number of stencils for WENO reconstruction (only different from weno_polyn for TENO(>5)) + integer :: muscl_lim !< MUSCL Limiter + integer :: num_fluids !< number of fluids in the simulation + logical :: wenojs !< WENO-JS (default) + logical :: mapped_weno !< WENO-M (WENO with mapping of nonlinear weights) + logical :: wenoz !< WENO-Z + logical :: teno !< TENO (Targeted ENO) + real(wp) :: wenoz_q !< Power constant for WENO-Z + logical :: mhd !< Magnetohydrodynamics + logical :: relativity !< Relativity (only for MHD) + integer :: igr_iter_solver !< IGR elliptic solver + integer :: igr_order !< Reconstruction order for IGR + logical :: igr !< Use information geometric regularization + logical :: igr_pres_lim !< Limit to positive pressures for IGR + logical :: viscous !< Viscous effects #:endif !> @name Variables for our of core IGR computation on NVIDIA !> @{ - logical :: nv_uvm_out_of_core ! Enable out-of-core storage of q_cons_ts(2) in timestepping (default FALSE) - integer :: nv_uvm_igr_temps_on_gpu ! 0 => jac, jac_rhs, and jac_old on CPU + logical :: nv_uvm_out_of_core ! Enable out-of-core storage of q_cons_ts(2) in timestepping (default FALSE) + integer :: nv_uvm_igr_temps_on_gpu ! 0 => jac, jac_rhs, and jac_old on CPU ! 1 => jac on GPU, jac_rhs and jac_old on CPU 2 => jac and jac_rhs on GPU, jac_old on CPU 3 => jac, jac_rhs, and jac_old on GPU ! (default) - logical :: nv_uvm_pref_gpu ! Enable explicit gpu memory hints (default FALSE) + logical :: nv_uvm_pref_gpu ! Enable explicit gpu memory hints (default FALSE) !> @} - real(wp) :: weno_eps !< Binding for the WENO nonlinear weights - real(wp) :: teno_CT !< Smoothness threshold for TENO - logical :: mp_weno !< Monotonicity preserving (MP) WENO - logical :: weno_avg ! Average left/right cell-boundary states - logical :: weno_Re_flux !< WENO reconstruct velocity gradients for viscous stress tensor - integer :: riemann_solver !< Riemann solver algorithm - integer :: low_Mach !< Low Mach number fix to HLLC Riemann solver - integer :: wave_speeds !< Wave speeds estimation method - integer :: avg_state !< Average state evaluation method - logical :: alt_soundspeed !< Alternate mixture sound speed - logical :: null_weights !< Null undesired WENO weights - logical :: mixture_err !< Mixture properties correction - logical :: hypoelasticity !< hypoelasticity modeling - logical :: hyperelasticity !< hyperelasticity modeling - logical :: int_comp !< THINC interface compression - real(wp) :: ic_eps !< THINC Epsilon to compress on surface cells - real(wp) :: ic_beta !< THINC Sharpness Parameter - integer :: hyper_model !< hyperelasticity solver algorithm - logical :: elasticity !< elasticity modeling, true for hyper or hypo - logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling - logical :: shear_stress !< Shear stresses - logical :: bulk_stress !< Bulk stresses - logical :: cont_damage !< Continuum damage modeling - logical :: hyper_cleaning !< Hyperbolic cleaning for MHD for divB=0 - integer :: num_igr_iters !< number of iterations for elliptic solve - integer :: num_igr_warm_start_iters !< number of warm start iterations for elliptic solve - real(wp) :: alf_factor !< alpha factor for IGR + real(wp) :: weno_eps !< Binding for the WENO nonlinear weights + real(wp) :: teno_CT !< Smoothness threshold for TENO + logical :: mp_weno !< Monotonicity preserving (MP) WENO + logical :: weno_avg ! Average left/right cell-boundary states + logical :: weno_Re_flux !< WENO reconstruct velocity gradients for viscous stress tensor + integer :: riemann_solver !< Riemann solver algorithm + integer :: low_Mach !< Low Mach number fix to HLLC Riemann solver + integer :: wave_speeds !< Wave speeds estimation method + integer :: avg_state !< Average state evaluation method + logical :: alt_soundspeed !< Alternate mixture sound speed + logical :: null_weights !< Null undesired WENO weights + logical :: mixture_err !< Mixture properties correction + logical :: hypoelasticity !< hypoelasticity modeling + logical :: hyperelasticity !< hyperelasticity modeling + logical :: int_comp !< THINC interface compression + real(wp) :: ic_eps !< THINC Epsilon to compress on surface cells + real(wp) :: ic_beta !< THINC Sharpness Parameter + integer :: hyper_model !< hyperelasticity solver algorithm + logical :: elasticity !< elasticity modeling, true for hyper or hypo + logical, parameter :: chemistry = .${chemistry}$. !< Chemistry modeling + logical :: shear_stress !< Shear stresses + logical :: bulk_stress !< Bulk stresses + logical :: cont_damage !< Continuum damage modeling + logical :: hyper_cleaning !< Hyperbolic cleaning for MHD for divB=0 + integer :: num_igr_iters !< number of iterations for elliptic solve + integer :: num_igr_warm_start_iters !< number of warm start iterations for elliptic solve + real(wp) :: alf_factor !< alpha factor for IGR logical :: bodyForces - logical :: bf_x, bf_y, bf_z !< body force toggle in three directions + logical :: bf_x, bf_y, bf_z !< body force toggle in three directions !> amplitude, frequency, and phase shift sinusoid in each direction #:for dir in {'x', 'y', 'z'} #:for param in {'k','w','p','g'} @@ -203,10 +203,10 @@ module m_global_parameters $:GPU_DECLARE(create='[hyperelasticity, hyper_model, elasticity, low_Mach]') $:GPU_DECLARE(create='[shear_stress, bulk_stress, cont_damage, hyper_cleaning]') - logical :: relax !< activate phase change - integer :: relax_model !< Relaxation model - real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model - real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model + logical :: relax !< activate phase change + integer :: relax_model !< Relaxation model + real(wp) :: palpha_eps !< trigger parameter for the p relaxation procedure, phase change model + real(wp) :: ptgalpha_eps !< trigger parameter for the pTg relaxation procedure, phase change model $:GPU_DECLARE(create='[relax, relax_model, palpha_eps, ptgalpha_eps]') integer :: num_bc_patches @@ -226,14 +226,14 @@ module m_global_parameters $:GPU_DECLARE(create='[x_domain, y_domain, z_domain]') real(wp) :: x_a, y_a, z_a real(wp) :: x_b, y_b, z_b - logical :: parallel_io !< Format of the data files - logical :: file_per_process !< shared file or not when using parallel io - integer :: precision !< Precision of output files - logical :: down_sample !< down sample the output files + logical :: parallel_io !< Format of the data files + logical :: file_per_process !< shared file or not when using parallel io + integer :: precision !< Precision of output files + logical :: down_sample !< down sample the output files $:GPU_DECLARE(create='[down_sample]') - integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM - integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid + integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM + integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid type(mpi_io_var), public :: MPI_IO_DATA type(mpi_io_ib_var), public :: MPI_IO_IB_DATA type(mpi_io_airfoil_ib_var), public :: MPI_IO_airfoil_IB_DATA @@ -250,26 +250,26 @@ module m_global_parameters !> @name Annotations of the structure of the state and flux vectors in terms of the size and the configuration of the system of !! equations to which they belong !> @{ - integer :: sys_size !< Number of unknowns in system of eqns. - type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. - type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. - integer :: E_idx !< Index of energy equation - integer :: n_idx !< Index of number density - type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. - type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. - type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. - integer :: alf_idx !< Index of void fraction - integer :: gamma_idx !< Index of specific heat ratio func. eqn. - integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. - type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. - type(int_bounds_info) :: stress_idx !< Indexes of first and last shear stress eqns. - type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. - integer :: b_size !< Number of elements in the symmetric b tensor, plus one - integer :: tensor_size !< Number of elements in the full tensor plus one - type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. - integer :: c_idx !< Index of color function - integer :: damage_idx !< Index of damage state variable (D) for continuum damage model - integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD + integer :: sys_size !< Number of unknowns in system of eqns. + type(int_bounds_info) :: cont_idx !< Indexes of first & last continuity eqns. + type(int_bounds_info) :: mom_idx !< Indexes of first & last momentum eqns. + integer :: E_idx !< Index of energy equation + integer :: n_idx !< Index of number density + type(int_bounds_info) :: adv_idx !< Indexes of first & last advection eqns. + type(int_bounds_info) :: internalEnergies_idx !< Indexes of first & last internal energy eqns. + type(bub_bounds_info) :: bub_idx !< Indexes of first & last bubble variable eqns. + integer :: alf_idx !< Index of void fraction + integer :: gamma_idx !< Index of specific heat ratio func. eqn. + integer :: pi_inf_idx !< Index of liquid stiffness func. eqn. + type(int_bounds_info) :: B_idx !< Indexes of first and last magnetic field eqns. + type(int_bounds_info) :: stress_idx !< Indexes of first and last shear stress eqns. + type(int_bounds_info) :: xi_idx !< Indexes of first and last reference map eqns. + integer :: b_size !< Number of elements in the symmetric b tensor, plus one + integer :: tensor_size !< Number of elements in the full tensor plus one + type(int_bounds_info) :: species_idx !< Indexes of first & last concentration eqns. + integer :: c_idx !< Index of color function + integer :: damage_idx !< Index of damage state variable (D) for continuum damage model + integer :: psi_idx !< Index of hyperbolic cleaning state variable for MHD !> @} $:GPU_DECLARE(create='[sys_size, E_idx, n_idx, bub_idx, alf_idx, gamma_idx]') $:GPU_DECLARE(create='[pi_inf_idx, B_idx, stress_idx, xi_idx, b_size]') @@ -318,8 +318,8 @@ module m_global_parameters $:GPU_DECLARE(create='[buff_size]') integer :: shear_num !! Number of shear stress components - integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, !! [indices]) integer, dimension(3, 2) :: shear_BC_flip_indices @@ -373,45 +373,45 @@ module m_global_parameters !> @name Bubble modeling !> @{ #:if MFC_CASE_OPTIMIZATION - integer, parameter :: nb = ${nb}$ !< Number of eq. bubble sizes + integer, parameter :: nb = ${nb}$ !< Number of eq. bubble sizes #:else - integer :: nb !< Number of eq. bubble sizes + integer :: nb !< Number of eq. bubble sizes #:endif - real(wp) :: Eu !< Euler number - real(wp) :: Ca !< Cavitation number - real(wp) :: Web !< Weber number - real(wp) :: Re_inv !< Inverse Reynolds number + real(wp) :: Eu !< Euler number + real(wp) :: Ca !< Cavitation number + real(wp) :: Web !< Weber number + real(wp) :: Re_inv !< Inverse Reynolds number $:GPU_DECLARE(create='[Eu, Ca, Web, Re_inv]') - real(wp), dimension(:), allocatable :: weight !< Simpson quadrature weights - real(wp), dimension(:), allocatable :: R0 !< Bubble sizes + real(wp), dimension(:), allocatable :: weight !< Simpson quadrature weights + real(wp), dimension(:), allocatable :: R0 !< Bubble sizes $:GPU_DECLARE(create='[weight, R0]') - logical :: bubbles_euler !< Bubbles euler on/off - logical :: polytropic !< Polytropic switch - logical :: polydisperse !< Polydisperse bubbles + logical :: bubbles_euler !< Bubbles euler on/off + logical :: polytropic !< Polytropic switch + logical :: polydisperse !< Polydisperse bubbles $:GPU_DECLARE(create='[bubbles_euler, polytropic, polydisperse]') - logical :: adv_n !< Solve the number density equation and compute alpha from number density - logical :: adap_dt !< Adaptive step size control - real(wp) :: adap_dt_tol !< Tolerance to control adaptive step size - integer :: adap_dt_max_iters !< Maximum number of iterations + logical :: adv_n !< Solve the number density equation and compute alpha from number density + logical :: adap_dt !< Adaptive step size control + real(wp) :: adap_dt_tol !< Tolerance to control adaptive step size + integer :: adap_dt_max_iters !< Maximum number of iterations $:GPU_DECLARE(create='[adv_n, adap_dt, adap_dt_tol, adap_dt_max_iters]') - integer :: bubble_model !< Gilmore or Keller--Miksis bubble model - integer :: thermal !< Thermal behavior. 1 = adiabatic, 2 = isotherm, 3 = transfer + integer :: bubble_model !< Gilmore or Keller--Miksis bubble model + integer :: thermal !< Thermal behavior. 1 = adiabatic, 2 = isotherm, 3 = transfer $:GPU_DECLARE(create='[bubble_model, thermal]') - real(wp), allocatable, dimension(:,:,:) :: ptil !< Pressure modification - real(wp) :: poly_sigma !< log normal sigma for polydisperse PDF + real(wp), allocatable, dimension(:,:,:) :: ptil !< Pressure modification + real(wp) :: poly_sigma !< log normal sigma for polydisperse PDF $:GPU_DECLARE(create='[ptil, poly_sigma]') - logical :: qbmm !< Quadrature moment method - integer, parameter :: nmom = 6 !< Number of carried moments per R0 location - integer :: nmomsp !< Number of moments required by ensemble-averaging - integer :: nmomtot !< Total number of carried moments moments/transport equations - real(wp) :: pi_fac !< Factor for artificial pi_inf + logical :: qbmm !< Quadrature moment method + integer, parameter :: nmom = 6 !< Number of carried moments per R0 location + integer :: nmomsp !< Number of moments required by ensemble-averaging + integer :: nmomtot !< Total number of carried moments moments/transport equations + real(wp) :: pi_fac !< Factor for artificial pi_inf $:GPU_DECLARE(create='[qbmm, nmomsp, nmomtot, pi_fac]') #:if not MFC_CASE_OPTIMIZATION @@ -445,9 +445,9 @@ module m_global_parameters !> @name Acoustic acoustic_source parameters !> @{ - logical :: acoustic_source !< Acoustic source switch - type(acoustic_parameters), dimension(num_probes_max) :: acoustic !< Acoustic source parameters - integer :: num_source !< Number of acoustic sources + logical :: acoustic_source !< Acoustic source switch + type(acoustic_parameters), dimension(num_probes_max) :: acoustic !< Acoustic source parameters + integer :: num_source !< Number of acoustic sources !> @} $:GPU_DECLARE(create='[acoustic_source, acoustic, num_source]') @@ -474,8 +474,8 @@ module m_global_parameters real(wp), allocatable, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps $:GPU_DECLARE(create='[gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps]') - real(wp) :: mytime !< Current simulation time - real(wp) :: finaltime !< Final simulation time + real(wp) :: mytime !< Current simulation time + real(wp) :: finaltime !< Final simulation time logical :: rdma_mpi type(pres_field), allocatable, dimension(:) :: pb_ts type(pres_field), allocatable, dimension(:) :: mv_ts @@ -484,12 +484,12 @@ module m_global_parameters !> @name lagrangian subgrid bubble parameters !> @{! - logical :: bubbles_lagrange !< Lagrangian subgrid bubble model switch - type(bubbles_lagrange_parameters) :: lag_params !< Lagrange bubbles' parameters + logical :: bubbles_lagrange !< Lagrangian subgrid bubble model switch + type(bubbles_lagrange_parameters) :: lag_params !< Lagrange bubbles' parameters $:GPU_DECLARE(create='[bubbles_lagrange, lag_params]') !> @} - real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) + real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) $:GPU_DECLARE(create='[Bx0]') logical :: fft_wrt @@ -498,16 +498,16 @@ module m_global_parameters logical :: dummy !> @name Continuum damage model parameters !> @{! - real(wp) :: tau_star !< Stress threshold for continuum damage modeling - real(wp) :: cont_damage_s !< Exponent s for continuum damage modeling - real(wp) :: alpha_bar !< Damage rate factor for continuum damage modeling + real(wp) :: tau_star !< Stress threshold for continuum damage modeling + real(wp) :: cont_damage_s !< Exponent s for continuum damage modeling + real(wp) :: alpha_bar !< Damage rate factor for continuum damage modeling $:GPU_DECLARE(create='[tau_star, cont_damage_s, alpha_bar]') !> @} !> @name MHD Hyperbolic cleaning parameters !> @{! - real(wp) :: hyper_cleaning_speed !< Hyperbolic cleaning wave speed (c_h) - real(wp) :: hyper_cleaning_tau !< Hyperbolic cleaning tau + real(wp) :: hyper_cleaning_speed !< Hyperbolic cleaning wave speed (c_h) + real(wp) :: hyper_cleaning_tau !< Hyperbolic cleaning tau $:GPU_DECLARE(create='[hyper_cleaning_speed, hyper_cleaning_tau]') !> @} @@ -517,7 +517,7 @@ contains !! parameters once they are read from the input file. impure subroutine s_assign_default_values_to_user_inputs - integer :: i, j !< Generic loop iterator + integer :: i, j !< Generic loop iterator ! Logistics case_dir = '.' @@ -548,7 +548,7 @@ contains ! NVIDIA UVM options nv_uvm_out_of_core = .false. - nv_uvm_igr_temps_on_gpu = 3 ! => jac, jac_rhs, and jac_old on GPU (default) + nv_uvm_igr_temps_on_gpu = 3 ! => jac, jac_rhs, and jac_old on GPU (default) nv_uvm_pref_gpu = .false. ! Simulation algorithm parameters @@ -654,8 +654,8 @@ contains bub_pp%gam_g = dflt_real; gam_g = dflt_real bub_pp%M_v = dflt_real; M_v = dflt_real bub_pp%M_g = dflt_real; M_g = dflt_real - bub_pp%k_v = dflt_real; - bub_pp%k_g = dflt_real; + bub_pp%k_v = dflt_real + bub_pp%k_g = dflt_real bub_pp%cp_v = dflt_real; cp_v = dflt_real bub_pp%cp_g = dflt_real; cp_g = dflt_real bub_pp%R_v = dflt_real; R_v = dflt_real @@ -912,7 +912,7 @@ contains if (igr) then ! IGR: volume fractions after energy (N-1 for N fluids; skipped when num_fluids=1) - adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 + adv_idx%beg = E_idx + 1 ! Alpha for fluid 1 adv_idx%end = E_idx + num_fluids - 1 else ! Volume fractions are stored in the indices immediately following the energy equation. WENO/MUSCL + Riemann @@ -932,7 +932,7 @@ contains if (bubbles_euler) then bub_idx%beg = sys_size + 1 if (qbmm) then - nmomsp = 4 ! number of special moments + nmomsp = 4 ! number of special moments if (nnode == 4) then ! nmom = 6 : It is already a parameter nmomtot = nmom*nb @@ -988,9 +988,9 @@ contains if (mhd) then B_idx%beg = sys_size + 1 if (n == 0) then - B_idx%end = sys_size + 2 ! 1D: By, Bz + B_idx%end = sys_size + 2 ! 1D: By, Bz else - B_idx%end = sys_size + 3 ! 2D/3D: Bx, By, Bz + B_idx%end = sys_size + 3 ! 2D/3D: Bx, By, Bz end if sys_size = B_idx%end end if @@ -1007,13 +1007,13 @@ contains internalEnergies_idx%end = adv_idx%end + num_fluids sys_size = internalEnergies_idx%end else if (model_eqns == 4) then - cont_idx%beg = 1 ! one continuity equation - cont_idx%end = 1 ! num_fluids - mom_idx%beg = cont_idx%end + 1 ! one momentum equation in each direction + cont_idx%beg = 1 ! one continuity equation + cont_idx%end = 1 ! num_fluids + mom_idx%beg = cont_idx%end + 1 ! one momentum equation in each direction mom_idx%end = cont_idx%end + num_vels - E_idx = mom_idx%end + 1 ! one energy equation + E_idx = mom_idx%end + 1 ! one energy equation adv_idx%beg = E_idx + 1 - adv_idx%end = adv_idx%beg ! one volume advection equation + adv_idx%end = adv_idx%beg ! one volume advection equation alf_idx = adv_idx%end sys_size = adv_idx%end @@ -1190,7 +1190,7 @@ contains fd_number = max(1, fd_order/2) end if - if (mhd) then ! TODO merge with above; waiting for hyperelasticity PR + if (mhd) then ! TODO merge with above; waiting for hyperelasticity PR fd_number = max(1, fd_order/2) end if @@ -1209,11 +1209,11 @@ contains $:GPU_UPDATE(device='[fd_order, fd_number]') - if (cyl_coord .neqv. .true.) then ! Cartesian grid + if (cyl_coord .neqv. .true.) then ! Cartesian grid grid_geometry = 1 - else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid + else if (cyl_coord .and. p == 0) then ! Axisymmetric cylindrical grid grid_geometry = 2 - else ! Fully 3D cylindrical grid + else ! Fully 3D cylindrical grid grid_geometry = 3 end if @@ -1276,7 +1276,7 @@ contains @:PREFER_GPU(x_cc) @:PREFER_GPU(dx) - if (n == 0) return; + if (n == 0) return @:ALLOCATE(y_cb(-1 - buff_size:n + buff_size)) @:ALLOCATE(y_cc(-buff_size:n + buff_size)) @:ALLOCATE(dy(-buff_size:n + buff_size)) @@ -1284,7 +1284,7 @@ contains @:PREFER_GPU(y_cc) @:PREFER_GPU(dy) - if (p == 0) return; + if (p == 0) return @:ALLOCATE(z_cb(-1 - buff_size:p + buff_size)) @:ALLOCATE(z_cc(-buff_size:p + buff_size)) @:ALLOCATE(dz(-buff_size:p + buff_size)) @@ -1298,7 +1298,7 @@ contains impure subroutine s_initialize_parallel_io #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors #endif #:if not MFC_CASE_OPTIMIZATION @@ -1366,10 +1366,10 @@ contains ! Deallocating grid variables for the x-, y- and z-directions @:DEALLOCATE(x_cb, x_cc, dx) - if (n == 0) return; + if (n == 0) return @:DEALLOCATE(y_cb, y_cc, dy) - if (p == 0) return; + if (p == 0) return @:DEALLOCATE(z_cb, z_cc, dz) end subroutine s_finalize_global_parameters_module diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index 8cef3e6784..d434fb1ff7 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -36,7 +36,7 @@ contains !! obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space impure subroutine s_initialize_hyperelastic_module - integer :: i !< generic iterator + integer :: i !< generic iterator @:ALLOCATE(btensor%vf(1:b_size)) do i = 1, b_size @@ -108,7 +108,7 @@ contains ! If in simulation, use acc mixture subroutines call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv, alpha_k, alpha_rho_k, Re, G_local, & - & Gs_hyper) + & Gs_hyper) rho = max(rho, sgm_eps) G_local = max(G_local, sgm_eps) @@ -213,7 +213,7 @@ contains integer, intent(in) :: j, k, l real(wp) :: trace real(wp), parameter :: f13 = 1._wp/3._wp - integer :: i !< Generic loop iterators + integer :: i !< Generic loop iterators ! tensor is the symmetric tensor & calculate the trace of the tensor trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) @@ -249,8 +249,8 @@ contains integer, intent(in) :: j, k, l real(wp) :: trace real(wp), parameter :: f13 = 1._wp/3._wp - integer :: i !< Generic loop iterators - ! TODO Make this 1D and 2D capable tensor is the symmetric tensor & calculate the trace of the tensor + integer :: i !< Generic loop iterators + ! TODO: Make 1D and 2D capable trace = btensor_in(1)%sf(j, k, l) + btensor_in(3)%sf(j, k, l) + btensor_in(6)%sf(j, k, l) ! Deviatoric left Cauchy-Green tensor: dev(b) = b - (tr(b)/3)*I @@ -271,7 +271,7 @@ contains !> @brief Deallocates memory for hyperelastic deformation tensor and finite-difference coefficients. impure subroutine s_finalize_hyperelastic_module() - integer :: i !< iterator + integer :: i !< iterator ! Deallocating memory do i = 1, b_size diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index 0b929bd61e..b28286bbff 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -88,8 +88,8 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf real(wp) :: rho_K, G_K - integer :: i, k, l, q, r !< Loop variables - integer :: ndirs !< Number of coordinate directions + integer :: i, k, l, q, r !< Loop variables + integer :: ndirs !< Number of coordinate directions ndirs = 1; if (n > 0) ndirs = 2; if (p > 0) ndirs = 3 @@ -153,8 +153,8 @@ contains do q = 0, p do l = 0, n do k = 0, m - du_dz_hypo(k, l, q) = 0._wp; dv_dz_hypo(k, l, q) = 0._wp; dw_dx_hypo(k, l, q) = 0._wp; - dw_dy_hypo(k, l, q) = 0._wp; dw_dz_hypo(k, l, q) = 0._wp; + du_dz_hypo(k, l, q) = 0._wp; dv_dz_hypo(k, l, q) = 0._wp; dw_dx_hypo(k, l, q) = 0._wp + dw_dy_hypo(k, l, q) = 0._wp; dw_dz_hypo(k, l, q) = 0._wp end do end do end do @@ -190,8 +190,8 @@ contains do k = 0, m rho_K = 0._wp; G_K = 0._wp do i = 1, num_fluids - rho_K = rho_K + q_prim_vf(i)%sf(k, l, q) ! alpha_rho_K(1) - G_K = G_K + q_prim_vf(advxb - 1 + i)%sf(k, l, q)*Gs_hypo(i) ! alpha_K(1) * Gs_hypo(1) + rho_K = rho_K + q_prim_vf(i)%sf(k, l, q) ! alpha_rho_K(1) + G_K = G_K + q_prim_vf(advxb - 1 + i)%sf(k, l, q)*Gs_hypo(i) ! alpha_K(1) * Gs_hypo(1) end do ! Continuum damage: (1-D) scales effective stiffness, D in [0,1] @@ -306,16 +306,16 @@ contains do k = 0, m ! S_xx -= rho * v/r * (tau_xx + 2/3*G) rhs_vf(strxb)%sf(k, l, q) = rhs_vf(strxb)%sf(k, l, q) - rho_K_field(k, l, q)*q_prim_vf(momxb + 1)%sf(k, & - & l, q)/y_cc(l)*(q_prim_vf(strxb)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_xx + 2/3*G + & l, q)/y_cc(l)*(q_prim_vf(strxb)%sf(k, l, q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_xx + 2/3*G ! S_xr -= rho * v/r * tau_xr rhs_vf(strxb + 1)%sf(k, l, q) = rhs_vf(strxb + 1)%sf(k, l, q) - rho_K_field(k, l, & - & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*q_prim_vf(strxb + 1)%sf(k, l, q) ! tau_xx + & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*q_prim_vf(strxb + 1)%sf(k, l, q) ! tau_xx ! S_rr -= rho * v/r * (tau_rr + 2/3*G) rhs_vf(strxb + 2)%sf(k, l, q) = rhs_vf(strxb + 2)%sf(k, l, q) - rho_K_field(k, l, & & q)*q_prim_vf(momxb + 1)%sf(k, l, q)/y_cc(l)*(q_prim_vf(strxb + 2)%sf(k, l, & - & q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_rr + 2/3*G + & q) + (2._wp/3._wp)*G_K_field(k, l, q)) ! tau_rr + 2/3*G ! S_thetatheta += rho * ( -(tau_thetatheta + 2/3*G)*(du/dx + dv/dr + v/r) + 2*(tau_thetatheta + G)*v/r ) rhs_vf(strxb + 3)%sf(k, l, q) = rhs_vf(strxb + 3)%sf(k, l, q) + rho_K_field(k, l, & @@ -354,7 +354,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - real(wp) :: tau_p ! principal stress + real(wp) :: tau_p ! principal stress real(wp) :: tau_xx, tau_xy, tau_yy, tau_zz, tau_yz, tau_xz real(wp) :: I1, I2, I3, argument, phi, sqrt_term_1, sqrt_term_2, temp integer :: q, l, k @@ -403,7 +403,7 @@ contains ! Maximum principal stress temp = I1**2.0_wp - 3.0_wp*I2 sqrt_term_1 = sqrt(max(temp, 0.0_wp)) - if (sqrt_term_1 > verysmall) then ! Avoid 0/0 + if (sqrt_term_1 > verysmall) then ! Avoid 0/0 argument = (2.0_wp*I1*I1*I1 - 9.0_wp*I1*I2 + 27.0_wp*I3)/(2.0_wp*sqrt_term_1*sqrt_term_1*sqrt_term_1) if (argument > 1.0_wp) argument = 1.0_wp if (argument < -1.0_wp) argument = -1.0_wp diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index c7f2fa8086..d262099973 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -12,8 +12,8 @@ !> @brief Immersed boundary patch geometry constructors for 2D and 3D shapes module m_ib_patches - use m_model ! Subroutine(s) related to STL files - use m_derived_types ! Definitions of the derived types + use m_model ! Subroutine(s) related to STL files + use m_derived_types ! Definitions of the derived types use m_global_parameters use m_helper_basic use m_helper @@ -47,7 +47,7 @@ module m_ib_patches !! patch boundaries in the x-, y- and z-coordinate directions. They are used as a means to concisely perform the actions !! necessary to lay out a particular patch on the grid. - character(len=5) :: istr ! string to store int to string result for error checking + character(len=5) :: istr ! string to store int to string result for error checking contains @@ -55,8 +55,8 @@ contains impure subroutine s_apply_ib_patches(ib_markers) type(integer_field), intent(inout) :: ib_markers - integer :: i, xp, yp, zp ! iterators - integer :: xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper ! periodic bounds + integer :: i, xp, yp, zp ! iterators + integer :: xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper ! periodic bounds ! 3D Patch Geometries @@ -121,11 +121,11 @@ contains subroutine s_ib_circle(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information type(integer_field), intent(inout) :: ib_markers real(wp), dimension(1:2) :: center real(wp) :: radius - integer :: i, j, il, ir, jl, jr !< Generic loop iterators + integer :: i, j, il, ir, jl, jr !< Generic loop iterators integer :: encoded_patch_id ! Transferring the circular patch's radius, centroid, smearing patch identity and smearing coefficient information @@ -166,14 +166,14 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information real(wp) :: f, ca_in, pa, ma, ta real(wp) :: xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c integer :: i, j, k, il, ir, jl, jr integer :: Np1, Np2 integer :: encoded_patch_id - real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) @@ -194,7 +194,7 @@ contains @:ALLOCATE(airfoil_grid_u(1:Np)) @:ALLOCATE(airfoil_grid_l(1:Np)) - ! TODO :: The below instantiations are already handles by the loop below + ! TODO :: The below instantiations are already handled by the loop below airfoil_grid_u(1)%x = 0._wp airfoil_grid_u(1)%y = 0._wp @@ -202,7 +202,7 @@ contains airfoil_grid_l(1)%y = 0._wp do i = 1, Np1 + Np2 - 1 - ! TODO :: This allocated the upper and lower airfoil arrays, and does not need to be performed each time the IB + ! TODO :: This allocates the upper and lower airfoil arrays, and does not need to be performed each time the IB ! markers are updated. Place this as a separate subroutine. if (i <= Np1) then xc = i*(pa*ca_in/Np1) @@ -264,9 +264,9 @@ contains & ca_in, airfoil_grid_u, airfoil_grid_l]', collapse=2) do j = jl, jr do i = il, ir - xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] ! get coordinate frame centered on IB - xy_local = matmul(inverse_rotation, xy_local) ! rotate the frame into the IB's coordinates - xy_local = xy_local - offset ! airfoils are a patch that require a centroid offset + xy_local = [x_cc(i) - center(1), y_cc(j) - center(2), 0._wp] ! get coordinate frame centered on IB + xy_local = matmul(inverse_rotation, xy_local) ! rotate the frame into the IB's coordinates + xy_local = xy_local - offset ! airfoils are a patch that require a centroid offset if (xy_local(1) >= 0._wp .and. xy_local(1) <= ca_in) then xa = xy_local(1)/ca_in @@ -328,12 +328,12 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information real(wp) :: lz, z_max, z_min, f, ca_in, pa, ma, ta, xa, yt, xu, yu, xl, yl, xc, yc, dycdxc, sin_c, cos_c integer :: i, j, k, l, il, ir, jl, jr, ll, lr integer :: Np1, Np2 integer :: encoded_patch_id - real(wp), dimension(1:3) :: xyz_local, center, offset !< x, y, z coordinates in local IB frame + real(wp), dimension(1:3) :: xyz_local, center, offset !< x, y, z coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) @@ -431,9 +431,9 @@ contains do j = jl, jr do i = il, ir xyz_local = [x_cc(i) - center(1), y_cc(j) - center(2), & - & z_cc(l) - center(3)] ! get coordinate frame centered on IB - xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates - xyz_local = xyz_local - offset ! airfoils are a patch that require a centroid offset + & z_cc(l) - center(3)] ! get coordinate frame centered on IB + xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates + xyz_local = xyz_local - offset ! airfoils are a patch that require a centroid offset if (xyz_local(3) >= z_min .and. xyz_local(3) <= z_max) then if (xyz_local(1) >= 0._wp .and. xyz_local(1) <= ca_in) then @@ -493,12 +493,12 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information - integer :: i, j, il, ir, jl, jr !< generic loop iterators + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer :: i, j, il, ir, jl, jr !< generic loop iterators integer :: encoded_patch_id - real(wp) :: corner_distance !< Equation of state parameters - real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: length, center !< x and y coordinates in local IB frame + real(wp) :: corner_distance !< Equation of state parameters + real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: length, center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation ! Transferring the rectangle's centroid and length information @@ -517,7 +517,7 @@ contains jl = -gp_layers - 1 ir = m + gp_layers + 1 jr = n + gp_layers + 1 - corner_distance = sqrt(dot_product(length, length))/2._wp ! maximum distance any marker can be from the center + corner_distance = sqrt(dot_product(length, length))/2._wp ! maximum distance any marker can be from the center call get_bounding_indices(center(1) - corner_distance, center(1) + corner_distance, x_cc, il, ir) call get_bounding_indices(center(2) - corner_distance, center(2) + corner_distance, y_cc, jl, jr) @@ -551,7 +551,7 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information ! Generic loop iterators integer :: i, j, k integer :: il, ir, jl, jr, kl, kr @@ -616,10 +616,10 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - integer :: i, j, k, ir, il, jr, jl, kr, kl !< Generic loop iterators + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer :: i, j, k, ir, il, jr, jl, kr, kl !< Generic loop iterators integer :: encoded_patch_id - real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation real(wp) :: corner_distance @@ -643,7 +643,7 @@ contains ir = m + gp_layers + 1 jr = n + gp_layers + 1 kr = p + gp_layers + 1 - corner_distance = sqrt(dot_product(length, length))/2._wp ! maximum distance any marker can be from the center + corner_distance = sqrt(dot_product(length, length))/2._wp ! maximum distance any marker can be from the center call get_bounding_indices(center(1) - corner_distance, center(1) + corner_distance, x_cc, il, ir) call get_bounding_indices(center(2) - corner_distance, center(2) + corner_distance, y_cc, jl, jr) call get_bounding_indices(center(3) - corner_distance, center(3) + corner_distance, z_cc, kl, kr) @@ -663,8 +663,8 @@ contains cart_y = y_cc(j) cart_z = z_cc(k) end if - xyz_local = [x_cc(i), cart_y, cart_z] - center ! get coordinate frame centered on IB - xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates + xyz_local = [x_cc(i), cart_y, cart_z] - center ! get coordinate frame centered on IB + xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates if (-0.5*length(1) <= xyz_local(1) .and. 0.5*length(1) >= xyz_local(1) .and. -0.5*length(2) <= xyz_local(2) & & .and. 0.5*length(2) >= xyz_local(2) .and. -0.5*length(3) <= xyz_local(3) .and. 0.5*length(3) & @@ -690,11 +690,11 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - integer :: i, j, k, il, ir, jl, jr, kl, kr !< Generic loop iterators + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer :: i, j, k, il, ir, jl, jr, kl, kr !< Generic loop iterators integer :: encoded_patch_id real(wp) :: radius - real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation real(wp) :: corner_distance @@ -718,7 +718,7 @@ contains ir = m + gp_layers + 1 jr = n + gp_layers + 1 kr = p + gp_layers + 1 - corner_distance = sqrt(radius**2 + maxval(length)**2) ! distance to rim of cylinder + corner_distance = sqrt(radius**2 + maxval(length)**2) ! distance to rim of cylinder call get_bounding_indices(center(1) - corner_distance, center(1) + corner_distance, x_cc, il, ir) call get_bounding_indices(center(2) - corner_distance, center(2) + corner_distance, y_cc, jl, jr) call get_bounding_indices(center(3) - corner_distance, center(3) + corner_distance, z_cc, kl, kr) @@ -737,8 +737,8 @@ contains cart_y = y_cc(j) cart_z = z_cc(k) end if - xyz_local = [x_cc(i), cart_y, cart_z] - center ! get coordinate frame centered on IB - xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates + xyz_local = [x_cc(i), cart_y, cart_z] - center ! get coordinate frame centered on IB + xyz_local = matmul(inverse_rotation, xyz_local) ! rotate the frame into the IB's coordinates if (((.not. f_is_default(length(1)) .and. xyz_local(2)**2 + xyz_local(3)**2 <= radius**2 .and. & & -0.5_wp*length(1) <= xyz_local(1) .and. 0.5_wp*length(1) >= xyz_local(1)) & @@ -761,12 +761,12 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information - integer :: i, j, il, ir, jl, jr !< Generic loop iterators + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer :: i, j, il, ir, jl, jr !< Generic loop iterators integer :: encoded_patch_id - real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame - real(wp), dimension(1:2) :: ellipse_coeffs !< a and b in the ellipse coefficients - real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame + real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame + real(wp), dimension(1:2) :: ellipse_coeffs !< a and b in the ellipse coefficients + real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame real(wp), dimension(1:3, 1:3) :: inverse_rotation ! Transferring the ellipse's centroid and length information @@ -815,8 +815,8 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp !< integers containing the periodicity projection information - integer :: i, j, k, il, ir, jl, jr !< Generic loop iterators + integer, intent(in) :: xp, yp !< integers containing the periodicity projection information + integer :: i, j, k, il, ir, jl, jr !< Generic loop iterators integer :: spc, encoded_patch_id integer :: cx, cy real(wp) :: lx(2), ly(2) @@ -894,8 +894,8 @@ contains integer, intent(in) :: patch_id type(integer_field), intent(inout) :: ib_markers - integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information - integer :: i, j, k, il, ir, jl, jr, kl, kr !< Generic loop iterators + integer, intent(in) :: xp, yp, zp !< integers containing the periodicity projection information + integer :: i, j, k, il, ir, jl, jr, kl, kr !< Generic loop iterators integer :: spc, encoded_patch_id real(wp) :: eta, threshold, corner_distance real(wp), dimension(1:3) :: point, local_point, offset diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index e383a64487..0f5e3e9bd4 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -32,7 +32,7 @@ module m_ibm type(ghost_point), dimension(:), allocatable :: ghost_points $:GPU_DECLARE(create='[ghost_points]') - integer :: num_gps !< Number of ghost points + integer :: num_gps !< Number of ghost points #if defined(MFC_OpenACC) $:GPU_DECLARE(create='[gp_layers, num_gps]') #elif defined(MFC_OpenMP) @@ -93,7 +93,7 @@ contains call s_apply_ib_patches(ib_markers) $:GPU_UPDATE(host='[ib_markers%sf]') do i = 1, num_ibs - if (patch_ib(i)%moving_ibm /= 0) call s_compute_centroid_offset(i) ! offsets are computed after IB markers are generated + if (patch_ib(i)%moving_ibm /= 0) call s_compute_centroid_offset(i) ! offsets are computed after IB markers are generated $:GPU_UPDATE(device='[patch_ib(i)]') end do @@ -127,12 +127,12 @@ contains !! @param mv_in Mass of vapor in bubble subroutine s_ibm_correct_state(q_cons_vf, q_prim_vf, pb_in, mv_in) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Primitive Variables - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive Variables + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Primitive Variables + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive Variables real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), optional, intent(inout) :: pb_in, mv_in - integer :: i, j, k, l, q, r !< Iterator variables - integer :: patch_id !< Patch ID of ghost point - real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables + integer :: i, j, k, l, q, r !< Iterator variables + integer :: patch_id !< Patch ID of ghost point + real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables real(wp), dimension(2) :: Re_K real(wp) :: G_K real(wp) :: qv_K @@ -155,11 +155,11 @@ contains #:endif !! Primitive variables at the image point associated with a ghost point, interpolated from surrounding fluid cells. - real(wp), dimension(3) :: norm !< Normal vector from GP to IP - real(wp), dimension(3) :: physical_loc !< Physical loc of GP - real(wp), dimension(3) :: vel_g !< Velocity of GP - real(wp), dimension(3) :: radial_vector !< vector from centroid to ghost point - real(wp), dimension(3) :: rotation_velocity !< speed of the ghost point due to rotation + real(wp), dimension(3) :: norm !< Normal vector from GP to IP + real(wp), dimension(3) :: physical_loc !< Physical loc of GP + real(wp), dimension(3) :: vel_g !< Velocity of GP + real(wp), dimension(3) :: radial_vector !< vector from centroid to ghost point + real(wp), dimension(3) :: rotation_velocity !< speed of the ghost point due to rotation real(wp) :: nbub real(wp) :: buf type(ghost_point) :: gp @@ -253,7 +253,7 @@ contains ! If in simulation, use acc mixture subroutines if (elasticity) then call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, alpha_rho_IP, Re_K, & - & G_K, Gs) + & G_K, Gs) else call s_convert_species_to_mixture_variables_acc(rho, gamma, pi_inf, qv_K, alpha_IP, alpha_rho_IP, Re_K) end if @@ -269,7 +269,7 @@ contains if (patch_ib(patch_id)%moving_ibm /= 0) then ! compute the linear velocity of the ghost point due to rotation radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, patch_ib(patch_id)%y_centroid, & - & patch_ib(patch_id)%z_centroid] + & patch_ib(patch_id)%z_centroid] call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), & & radial_vector, rotation_velocity) @@ -283,15 +283,15 @@ contains else ! get the vector that points from the centroid to the ghost radial_vector = physical_loc - [patch_ib(patch_id)%x_centroid, patch_ib(patch_id)%y_centroid, & - & patch_ib(patch_id)%z_centroid] + & patch_ib(patch_id)%z_centroid] ! convert the angular velocity from the inertial reference frame to the fluids frame, then convert to linear ! velocity call s_cross_product(matmul(patch_ib(patch_id)%rotation_matrix, patch_ib(patch_id)%angular_vel), & & radial_vector, rotation_velocity) do q = 1, 3 ! if mibm is 1 or 2, then the boundary may be moving - vel_g(q) = patch_ib(patch_id)%vel(q) ! add the linear velocity - vel_g(q) = vel_g(q) + rotation_velocity(q) ! add the rotational velocity + vel_g(q) = patch_ib(patch_id)%vel(q) ! add the linear velocity + vel_g(q) = vel_g(q) + rotation_velocity(q) ! add the rotational velocity end do end if end if @@ -385,9 +385,9 @@ contains real(wp), pointer, dimension(:) :: s_cc => null() integer :: bound type(ghost_point) :: gp - integer :: q, dim !< Iterator variables - integer :: i, j, k, l !< Location indexes - integer :: patch_id !< IB Patch ID + integer :: q, dim !< Iterator variables + integer :: i, j, k, l !< Location indexes + integer :: patch_id !< IB Patch ID integer :: dir integer :: index logical :: bounds_error @@ -458,12 +458,11 @@ contains print *, "y: ", y_cc(-buff_size), " to: ", y_cc(n + buff_size - 1) if (p /= 0) print *, "z: ", z_cc(-buff_size), " to: ", z_cc(p + buff_size - 1) print *, "Image point is located approximately ", & - & (ghost_points_in(q)%loc(dim) - ghost_points_in(q) & - & %ip_loc(dim))/(s_cc(1) - s_cc(0)), & - & " grid cells away" + & (ghost_points_in(q)%loc(dim) - ghost_points_in(q) %ip_loc(dim))/(s_cc(1) - s_cc(0)), & + & " grid cells away" print *, "Levelset ", dist, " and Norm: ", norm(:) print *, & - & "A short term fix may include increasing buff_size further in m_helper_basic (currently set to a minimum of 10)" + & "A short term fix may include increasing buff_size further in m_helper_basic (currently set to a minimum of 10)" #endif bounds_error = .true. end if @@ -488,8 +487,8 @@ contains subroutine s_find_num_ghost_points(num_gps_out) integer, intent(out) :: num_gps_out - integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables - integer :: num_gps_local !< local copies of the gp count to support GPU compute + integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables + integer :: num_gps_local !< local copies of the gp count to support GPU compute logical :: is_gp num_gps_local = 0 @@ -533,8 +532,8 @@ contains subroutine s_find_ghost_points(ghost_points_in) type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in - integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables - integer :: xp, yp, zp !< periodicities + integer :: i, j, k, ii, jj, kk, gp_layers_z !< Iterator variables + integer :: xp, yp, zp !< periodicities integer :: count, count_i, local_idx integer :: patch_id, encoded_patch_id logical :: is_gp @@ -624,7 +623,7 @@ contains real(wp) :: buf real(wp), dimension(2, 2, 2) :: eta type(ghost_point) :: gp - integer :: q, i, j, k, ii, jj, kk !< Grid indexes and iterators + integer :: q, i, j, k, ii, jj, kk !< Grid indexes and iterators integer :: patch_id logical is_cell_center @@ -638,7 +637,7 @@ contains if (p /= 0) then k = gp%ip_grid(3) else - k = 0; + k = 0 end if ! get the distance to a cell in each direction @@ -743,7 +742,7 @@ contains & nmom_IP, pb_in, mv_in, presb_IP, massv_IP) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !< Primitive Variables + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !< Primitive Variables real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(in) :: pb_in, mv_in type(ghost_point), intent(in) :: gp real(wp), intent(inout) :: pres_IP @@ -757,8 +756,8 @@ contains real(wp), optional, dimension(:), intent(inout) :: r_IP, v_IP, pb_IP, mv_IP real(wp), optional, dimension(:), intent(inout) :: nmom_IP real(wp), optional, dimension(:), intent(inout) :: presb_IP, massv_IP - integer :: i, j, k, l, q !< Iterator variables - integer :: i1, i2, j1, j2, k1, k2 !< Iterator variables + integer :: i, j, k, l, q !< Iterator variables + integer :: i1, i2, j1, j2, k1, k2 !< Iterator variables real(wp) :: coeff i1 = gp%ip_grid(1); i2 = i1 + 1 @@ -910,7 +909,7 @@ contains integer :: gp_id, i, j, k, l, q, ib_idx, fluid_idx real(wp), dimension(num_ibs, 3) :: forces, torques real(wp), dimension(1:3, 1:3) :: viscous_stress_div, viscous_stress_div_1, & - & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations + & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations real(wp), dimension(1:3) :: local_force_contribution, radial_vector, local_torque_contribution, vel real(wp) :: cell_volume, dx, dy, dz, dynamic_viscosity @@ -961,7 +960,7 @@ contains ! gradient of the pressure and cell volume local_force_contribution(1) = local_force_contribution(1) - (q_prim_vf(E_idx + fluid_idx)%sf(i + 1, & & j, k) - q_prim_vf(E_idx + fluid_idx)%sf(i - 1, j, & - & k))/(2._wp*dx) ! force is the negative pressure gradient + & k))/(2._wp*dx) ! force is the negative pressure gradient local_force_contribution(2) = local_force_contribution(2) - (q_prim_vf(E_idx + fluid_idx)%sf(i, & & j + 1, k) - q_prim_vf(E_idx + fluid_idx)%sf(i, j - 1, k))/(2._wp*dy) cell_volume = abs(dx*dy) @@ -981,23 +980,23 @@ contains do fluid_idx = 1, num_fluids ! local dynamic viscosity is the dynamic viscosity of the fluid times alpha of the fluid dynamic_viscosity = dynamic_viscosity + (q_prim_vf(fluid_idx + advxb - 1)%sf(i, j, & - & k)*dynamic_viscosities(fluid_idx)) + & k)*dynamic_viscosities(fluid_idx)) end do ! get the linear force components first call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i - 1, j, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i + 1, j, k) viscous_stress_div(1, 1:3) = (viscous_stress_div_2(1, 1:3) - viscous_stress_div_1(1, & - & 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor + & 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(1, & - & 1:3) ! add the x components of the divergence to the force + & 1:3) ! add the x components of the divergence to the force call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j - 1, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j + 1, k) viscous_stress_div(2, 1:3) = (viscous_stress_div_2(2, 1:3) - viscous_stress_div_1(2, & - & 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor + & 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(2, & - & 1:3) ! add the y components of the divergence to the force + & 1:3) ! add the y components of the divergence to the force if (num_dims == 3) then call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j, & @@ -1005,9 +1004,9 @@ contains call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j, & & k + 1) viscous_stress_div(3, 1:3) = (viscous_stress_div_2(3, 1:3) - viscous_stress_div_1(3, & - & 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor + & 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(3, & - & 1:3) ! add the z components of the divergence to the force + & 1:3) ! add the z components of the divergence to the force end if end if @@ -1047,7 +1046,7 @@ contains do i = 1, num_ibs patch_ib(i)%force(:) = forces(i,:) patch_ib(i)%torque(:) = matmul(patch_ib(i)%rotation_matrix_inverse, torques(i, & - & :)) ! torques must be converted to the local coordinates of the IB + & :)) ! torques must be converted to the local coordinates of the IB end do call nvtxEndRange @@ -1126,7 +1125,7 @@ contains !! @param ib_marker Immersed boundary marker index subroutine s_compute_moment_of_inertia(ib_marker, axis) - real(wp), dimension(3), intent(in) :: axis !< the axis about which we compute the moment. Only required in 3D. + real(wp), dimension(3), intent(in) :: axis !< the axis about which we compute the moment. Only required in 3D. integer, intent(in) :: ib_marker real(wp) :: moment, distance_to_axis, cell_volume real(wp), dimension(3) :: position, closest_point_along_axis, vector_to_axis, normal_axis @@ -1143,17 +1142,17 @@ contains end if ! if the IB is in 2D or a 3D sphere, we can compute this exactly - if (patch_ib(ib_marker)%geometry == 2) then ! circle + if (patch_ib(ib_marker)%geometry == 2) then ! circle patch_ib(ib_marker)%moment = 0.5_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%radius)**2 - else if (patch_ib(ib_marker)%geometry == 3) then ! rectangle + else if (patch_ib(ib_marker)%geometry == 3) then ! rectangle patch_ib(ib_marker)%moment = patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker) & & %length_y**2)/6._wp - else if (patch_ib(ib_marker)%geometry == 6) then ! ellipse + else if (patch_ib(ib_marker)%geometry == 6) then ! ellipse patch_ib(ib_marker)%moment = 0.0625_wp*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%length_x**2 + patch_ib(ib_marker) & & %length_y**2) - else if (patch_ib(ib_marker)%geometry == 8) then ! sphere + else if (patch_ib(ib_marker)%geometry == 8) then ! sphere patch_ib(ib_marker)%moment = 0.4*patch_ib(ib_marker)%mass*(patch_ib(ib_marker)%radius)**2 - else ! we do not have an analytic moment of inertia calculation and need to approximate it directly via a sum + else ! we do not have an analytic moment of inertia calculation and need to approximate it directly via a sum count = 0 moment = 0._wp cell_volume = (x_cc(1) - x_cc(0))*(y_cc(1) - y_cc(0)) @@ -1169,7 +1168,7 @@ contains do k = 0, p if (ib_markers%sf(i, j, k) == ib_marker) then $:GPU_ATOMIC(atomic='update') - count = count + 1 ! increment the count of total cells in the boundary + count = count + 1 ! increment the count of total cells in the boundary ! get the position in local coordinates so that the axis passes through 0, 0, 0 if (p == 0) then @@ -1183,7 +1182,7 @@ contains ! project the position along the axis to find the closest distance to the rotation axis closest_point_along_axis = normal_axis*dot_product(normal_axis, position) vector_to_axis = position - closest_point_along_axis - distance_to_axis = dot_product(vector_to_axis, vector_to_axis) ! saves the distance to the axis squared + distance_to_axis = dot_product(vector_to_axis, vector_to_axis) ! saves the distance to the axis squared ! compute the position component of the moment $:GPU_ATOMIC(atomic='update') diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index 64be97fafc..562c2b9baf 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -104,7 +104,7 @@ contains @:ALLOCATE(jac(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:ALLOCATE(jac_rhs(-1:m,-1:n,-1:p)) - if (igr_iter_solver == 1) then ! Jacobi iteration + if (igr_iter_solver == 1) then ! Jacobi iteration @:ALLOCATE(jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) end if #else @@ -129,7 +129,7 @@ contains jac_rhs(-1:m, -1:n, -1:p) => jac_rhs_host(:,:,:) end if - if (igr_iter_solver == 1) then ! Jacobi iteration + if (igr_iter_solver == 1) then ! Jacobi iteration if (nv_uvm_temp_on_gpu(3) == 1) then @:ALLOCATE(jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(jac_old) @@ -162,7 +162,7 @@ contains #:if not MFC_CASE_OPTIMIZATION if (igr_order == 3) then - vidxb = -1; vidxe = 2; + vidxb = -1; vidxe = 2 $:GPU_UPDATE(device='[vidxb, vidxe]') @:ALLOCATE(coeff_L(0:2)) @@ -175,7 +175,7 @@ contains coeff_R(0) = (5._wp/6._wp) coeff_R(-1) = (-1._wp/6._wp) else if (igr_order == 5) then - vidxb = -2; vidxe = 3; + vidxb = -2; vidxe = 3 $:GPU_UPDATE(device='[vidxb, vidxe]') @:ALLOCATE(coeff_L(-1:3)) @@ -259,7 +259,7 @@ contains fd_coeff = fd_coeff + alf_igr*(1._wp/dz(l)**2._wp)*(1._wp/rho_lz + 1._wp/rho_rz) end if - if (igr_iter_solver == 1) then ! Jacobi iteration + if (igr_iter_solver == 1) then ! Jacobi iteration if (num_dims == 3) then jac(j, k, l) = real((alf_igr/fd_coeff)*((1._wp/dx(j)**2._wp)*(jac_old(j - 1, k, & & l)/rho_lx + jac_old(j + 1, k, l)/rho_rx) + (1._wp/dy(k)**2._wp)*(jac_old(j, k - 1, & @@ -273,7 +273,7 @@ contains & kind=wp)/rho_ly + real(jac_old(j, k + 1, l), kind=wp)/rho_ry)) + real(jac_rhs(j, k, l), & & kind=wp)/fd_coeff, kind=stp) end if - else ! Gauss Seidel iteration + else ! Gauss Seidel iteration if (num_dims == 3) then jac(j, k, l) = real((alf_igr/fd_coeff)*((1._wp/dx(j)**2._wp)*(jac(j - 1, k, & & l)/rho_lx + jac(j + 1, k, l)/rho_rx) + (1._wp/dy(k)**2._wp)*(jac(j, k - 1, & @@ -293,7 +293,7 @@ contains call s_populate_F_igr_buffers(bc_type, jac_sf) - if (igr_iter_solver == 1 .or. dummy) then ! Jacobi iteration + if (igr_iter_solver == 1 .or. dummy) then ! Jacobi iteration $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = idwbuff(3)%beg, idwbuff(3)%end do k = idwbuff(2)%beg, idwbuff(2)%end @@ -2716,7 +2716,7 @@ contains #ifndef __NVCOMPILER_GPU_UNIFIED_MEM @:DEALLOCATE(jac, jac_rhs) - if (igr_iter_solver == 1) then ! Jacobi iteration + if (igr_iter_solver == 1) then ! Jacobi iteration @:DEALLOCATE(jac_old) end if #else @@ -2734,7 +2734,7 @@ contains deallocate (jac_rhs_host) end if - if (igr_iter_solver == 1) then ! Jacobi iteration + if (igr_iter_solver == 1) then ! Jacobi iteration if (nv_uvm_temp_on_gpu(3) == 1) then @:DEALLOCATE(jac_old) else diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index aec11b1d37..4502afd92e 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -9,7 +9,7 @@ module m_mpi_proxy #ifdef MFC_MPI - use mpi !< Message passing interface (MPI) module + use mpi !< Message passing interface (MPI) module #endif use m_helper_basic @@ -62,8 +62,8 @@ contains impure subroutine s_mpi_bcast_user_inputs() #ifdef MFC_MPI - integer :: i, j !< Generic loop iterator - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: i, j !< Generic loop iterator + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_BCAST(case_dir, len(case_dir), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) @@ -248,7 +248,7 @@ contains real(wp), intent(inout), dimension(1:num_freq) :: phi_rn #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors call MPI_BCAST(phi_rn, num_freq, mpi_p, 0, MPI_COMM_WORLD, ierr) #endif diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index eb008a248d..fc3d17a7c6 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -44,7 +44,7 @@ contains if (n == 0) then is2_muscl%beg = 0 else - is2_muscl%beg = -buff_size; + is2_muscl%beg = -buff_size end if is2_muscl%end = n - is2_muscl%beg @@ -168,27 +168,27 @@ contains slopeR = v_rs_ws_${XYZ}$_muscl(j, k, l, i) - v_rs_ws_${XYZ}$_muscl(j - 1, k, l, i) slope = 0._wp - if (muscl_lim == 1) then ! minmod + if (muscl_lim == 1) then ! minmod if (slopeL*slopeR > 1e-9_wp) then slope = min(abs(slopeL), abs(slopeR)) end if if (slopeL < 0._wp) slope = -slope - else if (muscl_lim == 2) then ! MC + else if (muscl_lim == 2) then ! MC if (slopeL*slopeR > 1e-9_wp) then slope = min(2._wp*abs(slopeL), 2._wp*abs(slopeR)) slope = min(slope, 5e-1_wp*(abs(slopeL) + abs(slopeR))) end if if (slopeL < 0._wp) slope = -slope - else if (muscl_lim == 3) then ! Van Albada + else if (muscl_lim == 3) then ! Van Albada if (abs(slopeL) > 1e-6_wp .and. abs(slopeR) > 1e-6_wp .and. abs(slopeL + slopeR) & & > 1e-6_wp .and. slopeL*slopeR > 1e-6_wp) then slope = ((slopeL + slopeR)*slopeL*slopeR)/(slopeL**2._wp + slopeR**2._wp) end if - else if (muscl_lim == 4) then ! Van Leer + else if (muscl_lim == 4) then ! Van Leer if (abs(slopeL + slopeR) > 1.e-6_wp .and. slopeL*slopeR > 1.e-6_wp) then slope = 2._wp*slopeL*slopeR/(slopeL + slopeR) end if - else if (muscl_lim == 5) then ! SUPERBEE + else if (muscl_lim == 5) then ! SUPERBEE if (slopeL*slopeR > 1e-6_wp) then slope = -1._wp*min(-min(2._wp*abs(slopeL), abs(slopeR)), -min(abs(slopeL), & & 2._wp*abs(slopeR))) @@ -240,7 +240,7 @@ contains moncon = (aCR - aC)*(aC - aCL) - if (aC >= ic_eps .and. aC <= 1._wp - ic_eps .and. moncon > moncon_cutoff) then ! Interface cell + if (aC >= ic_eps .and. aC <= 1._wp - ic_eps .and. moncon > moncon_cutoff) then ! Interface cell if (aCR - aCL > 0._wp) then sign = 1._wp @@ -291,7 +291,7 @@ contains type(scalar_field), dimension(:), intent(in) :: v_vf integer, intent(in) :: muscl_dir - integer :: j, k, l, q !< Generic loop iterators + integer :: j, k, l, q !< Generic loop iterators ! Determine MUSCL-reconstructed variables and map coordinate directions v_size = ubound(v_vf, 1) diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index 04e0793fa4..c78d6a056d 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -410,7 +410,7 @@ contains real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & - & intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. + & intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. integer :: i, j, k, l, q real(wp) :: nb_q, nb_dot, R, R2, nR, nR2, nR_dot, nR2_dot, var, AX @@ -1020,8 +1020,8 @@ contains bu = fmom(2)/fmom(1) d2 = fmom(3)/fmom(1) c2 = d2 - bu**2._wp - frho(1) = fmom(1)/2._wp; - frho(2) = fmom(1)/2._wp; + frho(1) = fmom(1)/2._wp + frho(2) = fmom(1)/2._wp c2 = maxval((/c2, sgm_eps/)) fup(1) = bu - sqrt(c2) fup(2) = bu + sqrt(c2) diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 7ebbd43bb9..938c9809f5 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -103,7 +103,7 @@ module m_rhs $:GPU_DECLARE(create='[qL_prim, qR_prim]') #endif - type(int_bounds_info) :: iv !< Vector field indical bounds + type(int_bounds_info) :: iv !< Vector field indical bounds $:GPU_DECLARE(create='[iv]') !> @name Indical bounds in the x-, y- and z-directions @@ -128,7 +128,7 @@ module m_rhs $:GPU_DECLARE(create='[qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, qR_rsx_vf, qR_rsy_vf, qR_rsz_vf]') $:GPU_DECLARE(create='[dqL_rsx_vf, dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf]') - real(wp), allocatable, dimension(:,:,:) :: nbub !< Bubble number density + real(wp), allocatable, dimension(:,:,:) :: nbub !< Bubble number density $:GPU_DECLARE(create='[nbub]') contains @@ -137,7 +137,7 @@ contains !! procedures that are necessary to setup the module. impure subroutine s_initialize_rhs_module - integer :: i, j, k, l, id !< Generic loop iterators + integer :: i, j, k, l, id !< Generic loop iterators $:GPU_ENTER_DATA(copyin='[idwbuff]') $:GPU_UPDATE(device='[idwbuff]') @@ -462,7 +462,7 @@ contains @:ALLOCATE(dqR_rsz_vf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & & idwbuff(3)%beg:idwbuff(3)%end, mom_idx%beg:mom_idx%end)) end if - end if ! end allocation for weno_Re_flux + end if ! end allocation for weno_Re_flux else @:ALLOCATE(dq_prim_dx_qp(1)%vf(1:sys_size)) @:ALLOCATE(dq_prim_dy_qp(1)%vf(1:sys_size)) @@ -480,7 +480,7 @@ contains end if end if end do - end if ! end allocation of viscous variables + end if ! end allocation of viscous variables $:GPU_PARALLEL_LOOP(private='[i, j, k, l, id]', collapse=4) do id = 1, num_dims @@ -495,7 +495,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - end if ! end allocation for .not. igr + end if ! end allocation for .not. igr if (qbmm) then @:ALLOCATE(mom_sp(1:nmomsp), mom_3d(0:2, 0:2, nb)) @@ -552,7 +552,7 @@ contains real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & & intent(inout) & - & :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now + & :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: mv_in real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv integer, intent(in) :: t_step @@ -560,7 +560,7 @@ contains integer, intent(in) :: stage real(wp) :: t_start, t_finish integer :: id - integer(kind=8) :: i, j, k, l, q !< Generic loop iterators + integer(kind=8) :: i, j, k, l, q !< Generic loop iterators ! RHS: halo exchange -> reconstruct -> Riemann solve -> flux difference -> source terms @@ -679,7 +679,7 @@ contains call nvtxEndRange end if end if - if ((.not. igr) .or. dummy) then ! Finite volume solve + if ((.not. igr) .or. dummy) then ! Finite volume solve ! Reconstructing Primitive/Conservative Variables call nvtxStartRange("RHS-WENO") @@ -707,7 +707,7 @@ contains iv%beg = E_idx; iv%end = E_idx call s_reconstruct_cell_boundary_values_first_order(q_prim_qp%vf(E_idx), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx + 1; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & @@ -719,7 +719,7 @@ contains iv%beg = E_idx; iv%end = E_idx call s_reconstruct_cell_boundary_values_first_order(q_prim_qp%vf(E_idx), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & - & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) + & qR_rsx_vf, qR_rsy_vf, qR_rsz_vf, id) iv%beg = E_idx + 1; iv%end = sys_size call s_reconstruct_cell_boundary_values(q_prim_qp%vf(iv%beg:iv%end), qL_rsx_vf, qL_rsy_vf, qL_rsz_vf, & @@ -731,28 +731,23 @@ contains if (weno_Re_flux) then iv%beg = momxb; iv%end = momxe call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dx_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & - & dqR_rsz_vf, id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), & - & dqR_prim_dx_n(id)%vf(iv%beg:iv%end), idwbuff(1), & - & idwbuff(2), idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, dqL_prim_dx_n(id)%vf(iv%beg:iv%end), & + & dqR_prim_dx_n(id)%vf(iv%beg:iv%end), idwbuff(1), idwbuff(2), idwbuff(3)) if (n > 0) then call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dy_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & - & dqR_rsz_vf, id, dqL_prim_dy_n(id)%vf(iv%beg:iv%end), & - & dqR_prim_dy_n(id)%vf(iv%beg:iv%end), idwbuff(1), & - & idwbuff(2), idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, & + & dqL_prim_dy_n(id)%vf(iv%beg:iv%end), dqR_prim_dy_n(id)%vf(iv%beg:iv%end), idwbuff(1), idwbuff(2), & + & idwbuff(3)) if (p > 0) then call s_reconstruct_cell_boundary_values_visc_deriv(dq_prim_dz_qp(1)%vf(iv%beg:iv%end), dqL_rsx_vf, & - & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, & - & dqR_rsz_vf, id, & - & dqL_prim_dz_n(id)%vf(iv%beg:iv%end), & - & dqR_prim_dz_n(id)%vf(iv%beg:iv%end), idwbuff(1), & - & idwbuff(2), idwbuff(3)) + & dqL_rsy_vf, dqL_rsz_vf, dqR_rsx_vf, dqR_rsy_vf, dqR_rsz_vf, id, & + & dqL_prim_dz_n(id)%vf(iv%beg:iv%end), dqR_prim_dz_n(id)%vf(iv%beg:iv%end), idwbuff(1), & + & idwbuff(2), idwbuff(3)) end if end if end if - call nvtxEndRange ! WENO + call nvtxEndRange ! WENO ! Configuring Coordinate Direction Indexes if (id == 1) then @@ -918,8 +913,8 @@ contains type(vector_field), intent(inout) :: q_cons_vf type(vector_field), intent(inout) :: q_prim_vf type(vector_field), intent(inout) :: flux_src_n_vf - integer :: j, k, l, q ! Loop iterators from original, meaning varies - integer :: k_loop, l_loop, q_loop ! Standardized spatial loop iterators 0:m, 0:n, 0:p + integer :: j, k, l, q ! Loop iterators from original, meaning varies + integer :: k_loop, l_loop, q_loop ! Standardized spatial loop iterators 0:m, 0:n, 0:p integer :: i_fluid_loop real(wp) :: inv_ds, flux_face1, flux_face2 real(wp) :: advected_qty_val, pressure_val, velocity_val @@ -952,7 +947,7 @@ contains end if select case (idir) - case (1) ! x-direction + case (1) ! x-direction if (bc_x%beg <= BC_CHAR_SLIP_WALL .and. bc_x%beg >= BC_CHAR_SUP_OUTFLOW) then call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, -1, irx, iry, irz) end if @@ -998,7 +993,7 @@ contains end if call s_add_directional_advection_source_terms(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf, Kterm) - case (2) ! y-direction + case (2) ! y-direction if (bc_y%beg <= BC_CHAR_SLIP_WALL .and. bc_y%beg >= BC_CHAR_SUP_OUTFLOW) then call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, -1, irx, iry, irz) end if @@ -1063,7 +1058,7 @@ contains end if call s_add_directional_advection_source_terms(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf, Kterm) - case (3) ! z-direction + case (3) ! z-direction if (bc_z%beg <= BC_CHAR_SLIP_WALL .and. bc_z%beg >= BC_CHAR_SUP_OUTFLOW) then call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, -1, irx, iry, irz) end if @@ -1071,7 +1066,7 @@ contains call s_cbc(q_prim_vf%vf, flux_n(idir)%vf, flux_src_n_vf%vf, idir, 1, irx, iry, irz) end if - if (grid_geometry == 3) then ! Cylindrical Coordinates + if (grid_geometry == 3) then ! Cylindrical Coordinates $:GPU_PARALLEL_LOOP(collapse=4,private='[j, k, l, q, inv_ds, velocity_val, flux_face1, flux_face2]') do j = 1, sys_size do k = 0, p @@ -1100,7 +1095,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - else ! Cartesian Coordinates + else ! Cartesian Coordinates $:GPU_PARALLEL_LOOP(collapse=4,private='[j, k, l, q, inv_ds, flux_face1, flux_face2]') do j = 1, sys_size do k = 0, p @@ -1160,15 +1155,15 @@ contains logical :: use_standard_riemann select case (current_idir) - case (1) ! x-direction + case (1) ! x-direction use_standard_riemann = (riemann_solver == 1 .or. riemann_solver == 4) if (use_standard_riemann) then $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & & local_flux1, local_flux2]') do j_adv = advxb, advxe - do q_idx = 0, p ! z_extent - do l_idx = 0, n ! y_extent - do k_idx = 0, m ! x_extent + do q_idx = 0, p ! z_extent + do l_idx = 0, n ! y_extent + do k_idx = 0, m ! x_extent local_inv_ds = 1._wp/dx(k_idx) local_term_coeff = q_prim_vf_arg%vf(contxe + current_idir)%sf(k_idx, l_idx, q_idx) local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(k_idx - 1, l_idx, q_idx) @@ -1180,7 +1175,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - else ! Other Riemann solvers + else ! Other Riemann solvers if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & @@ -1188,7 +1183,7 @@ contains do q_idx = 0, p; do l_idx = 0, n; do k_idx = 0, m local_inv_ds = 1._wp/dx(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) - local_k_term_val = Kterm_arg(k_idx, l_idx, q_idx) ! Access is safe due to outer alt_soundspeed check + local_k_term_val = Kterm_arg(k_idx, l_idx, q_idx) ! Access is safe due to outer alt_soundspeed check local_term_coeff = local_q_cons_val - local_k_term_val local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(k_idx - 1, l_idx, q_idx) @@ -1202,7 +1197,7 @@ contains do q_idx = 0, p; do l_idx = 0, n; do k_idx = 0, m local_inv_ds = 1._wp/dx(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) - local_k_term_val = Kterm_arg(k_idx, l_idx, q_idx) ! Access is safe + local_k_term_val = Kterm_arg(k_idx, l_idx, q_idx) ! Access is safe local_term_coeff = local_q_cons_val + local_k_term_val local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx, l_idx, q_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(k_idx - 1, l_idx, q_idx) @@ -1211,7 +1206,7 @@ contains end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if - else ! NOT alt_soundspeed + else ! NOT alt_soundspeed $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & & local_flux1, local_flux2]') do j_adv = advxb, advxe @@ -1234,9 +1229,9 @@ contains $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & & local_flux1, local_flux2]') do j_adv = advxb, advxe - do l_idx = 0, p ! z_extent - do k_idx = 0, n ! y_extent - do q_idx = 0, m ! x_extent + do l_idx = 0, p ! z_extent + do k_idx = 0, n ! y_extent + do q_idx = 0, m ! x_extent local_inv_ds = 1._wp/dy(k_idx) local_term_coeff = q_prim_vf_arg%vf(contxe + current_idir)%sf(q_idx, k_idx, l_idx) local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(q_idx, k_idx - 1, l_idx) @@ -1248,7 +1243,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - else ! Other Riemann solvers + else ! Other Riemann solvers if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & @@ -1256,7 +1251,7 @@ contains do l_idx = 0, p; do k_idx = 0, n; do q_idx = 0, m local_inv_ds = 1._wp/dy(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) - local_k_term_val = Kterm_arg(q_idx, k_idx, l_idx) ! Access is safe + local_k_term_val = Kterm_arg(q_idx, k_idx, l_idx) ! Access is safe local_term_coeff = local_q_cons_val - local_k_term_val local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx, l_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(q_idx, k_idx - 1, l_idx) @@ -1274,7 +1269,7 @@ contains do l_idx = 0, p; do k_idx = 0, n; do q_idx = 0, m local_inv_ds = 1._wp/dy(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) - local_k_term_val = Kterm_arg(q_idx, k_idx, l_idx) ! Access is safe + local_k_term_val = Kterm_arg(q_idx, k_idx, l_idx) ! Access is safe local_term_coeff = local_q_cons_val + local_k_term_val local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx, l_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(q_idx, k_idx - 1, l_idx) @@ -1287,7 +1282,7 @@ contains end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if - else ! NOT alt_soundspeed + else ! NOT alt_soundspeed $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & & local_flux1, local_flux2]') do j_adv = advxb, advxe @@ -1315,9 +1310,9 @@ contains $:GPU_PARALLEL_LOOP(collapse=4,private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & & local_flux1, local_flux2]') do j_adv = advxb, advxe - do k_idx = 0, p ! z_extent - do q_idx = 0, n ! y_extent - do l_idx = 0, m ! x_extent + do k_idx = 0, p ! z_extent + do q_idx = 0, n ! y_extent + do l_idx = 0, m ! x_extent local_inv_ds = 1._wp/dz(k_idx) local_term_coeff = q_prim_vf_arg%vf(contxe + current_idir)%sf(l_idx, q_idx, k_idx) local_flux1 = flux_src_n_vf_arg%vf(j_adv)%sf(l_idx, q_idx, k_idx - 1) @@ -1329,7 +1324,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - else ! Other Riemann solvers + else ! Other Riemann solvers if (alt_soundspeed) then if (bubbles_euler .neqv. .true.) then $:GPU_PARALLEL_LOOP(collapse=3, private='[k_idx, l_idx, q_idx, local_inv_ds, local_q_cons_val, & @@ -1337,7 +1332,7 @@ contains do k_idx = 0, p; do q_idx = 0, n; do l_idx = 0, m local_inv_ds = 1._wp/dz(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) - local_k_term_val = Kterm_arg(l_idx, q_idx, k_idx) ! Access is safe + local_k_term_val = Kterm_arg(l_idx, q_idx, k_idx) ! Access is safe local_term_coeff = local_q_cons_val - local_k_term_val local_flux1 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx) local_flux2 = flux_src_n_vf_arg%vf(advxe)%sf(l_idx, q_idx, k_idx - 1) @@ -1351,7 +1346,7 @@ contains do k_idx = 0, p; do q_idx = 0, n; do l_idx = 0, m local_inv_ds = 1._wp/dz(k_idx) local_q_cons_val = q_cons_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) - local_k_term_val = Kterm_arg(l_idx, q_idx, k_idx) ! Access is safe + local_k_term_val = Kterm_arg(l_idx, q_idx, k_idx) ! Access is safe local_term_coeff = local_q_cons_val + local_k_term_val local_flux1 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx) local_flux2 = flux_src_n_vf_arg%vf(advxb)%sf(l_idx, q_idx, k_idx - 1) @@ -1360,7 +1355,7 @@ contains end do; end do; end do $:END_GPU_PARALLEL_LOOP() end if - else ! NOT alt_soundspeed + else ! NOT alt_soundspeed $:GPU_PARALLEL_LOOP(collapse=4, private='[j_adv, k_idx, l_idx, q_idx, local_inv_ds, local_term_coeff, & & local_flux1, local_flux2]') do j_adv = advxb, advxe @@ -1392,7 +1387,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: dq_prim_dx_vf, dq_prim_dy_vf, dq_prim_dz_vf integer :: i, j, k, l - if (idir == 1) then ! x-direction + if (idir == 1) then ! x-direction if (surface_tension) then $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) @@ -1438,7 +1433,7 @@ contains end do $:END_GPU_PARALLEL_LOOP() end if - else if (idir == 2) then ! y-direction + else if (idir == 2) then ! y-direction if (surface_tension) then $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p @@ -1456,14 +1451,12 @@ contains if (viscous .or. dummy) then if (p > 0) then call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & - & idwbuff(1), idwbuff(2), idwbuff(3)) + & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & + & idwbuff(1), idwbuff(2), idwbuff(3)) else call s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, dq_prim_dx_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), & - & dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & - & idwbuff(1), idwbuff(2), idwbuff(3)) + & dq_prim_dy_vf(mom_idx%beg:mom_idx%end), dq_prim_dz_vf(mom_idx%beg:mom_idx%end), tau_Re_vf, & + & idwbuff(1), idwbuff(2), idwbuff(3)) end if $:GPU_PARALLEL_LOOP(private='[i, j, l]', collapse=2) @@ -1570,7 +1563,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if end if - else if (idir == 3) then ! z-direction + else if (idir == 3) then ! z-direction if (surface_tension) then $:GPU_PARALLEL_LOOP(private='[j, k, l]', collapse=3) do l = 0, p @@ -1650,7 +1643,7 @@ contains real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir - integer :: recon_dir !< Coordinate direction of the reconstruction + integer :: recon_dir !< Coordinate direction of the reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] @@ -1696,7 +1689,7 @@ contains real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir - integer :: recon_dir !< Coordinate direction of the WENO reconstruction + integer :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l ! Reconstruction in s1-direction diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index aa0ac5adc5..492547e77d 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -150,10 +150,10 @@ contains if (grid_geometry == 3) then call s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & - & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, norm_dir, ix, iy, iz) + & dvelR_dy_vf, dvelR_dz_vf, flux_src_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, norm_dir) + & dvelR_dz_vf, flux_src_vf, norm_dir) end if end subroutine s_compute_viscous_source_flux @@ -224,20 +224,19 @@ contains 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 + 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) :: 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 + type(riemann_states_vec3) :: b4 ! 4-magnetic field components (spatial: b4x, b4y, b4z) + type(riemann_states_vec3) :: cm ! Conservative momentum variables + integer :: i, j, k, l, q !< Generic loop iterators ! Populating the buffers of the left and right Riemann problem states variables, based on the choice of boundary conditions call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction call s_initialize_riemann_solver(flux_src_vf, norm_dir) @@ -281,14 +280,14 @@ contains pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables + if (n == 0) then ! 1D: constant Bx; By, Bz as variables B%L(1) = Bx0 B%R(1) = Bx0 B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) - else ! 2D/3D: Bx, By, Bz as variables + else ! 2D/3D: Bx, By, Bz as variables B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) @@ -447,10 +446,10 @@ contains #:endif E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R & - & + pres_mag%R ! includes magnetic energy + & + pres_mag%R ! includes magnetic energy H_L = (E_L + pres_L - pres_mag%L)/rho_L H_R = (E_R + pres_R - pres_mag%R) & - & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 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 @@ -702,7 +701,7 @@ contains ! Elastic Stresses if (hypoelasticity) then - do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow + do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow flux_rs${XYZ}$_vf(j, k, l, & & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & @@ -741,7 +740,7 @@ contains ! MHD: magnetic flux and Maxwell stress contributions if (mhd) then - if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. + 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 @@ -750,7 +749,7 @@ contains & - 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 + 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}$) @@ -775,7 +774,7 @@ contains else flux_rs${XYZ}$_vf(j, k, l, & & B_idx%beg + norm_dir - 1) & - & = 0._wp ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero + & = 0._wp ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero end if end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -862,7 +861,7 @@ contains 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)`. + 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 @@ -904,21 +903,20 @@ contains 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 + 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) :: 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. + 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, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction call s_initialize_riemann_solver(flux_src_vf, norm_dir) @@ -962,14 +960,14 @@ contains pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables + if (n == 0) then ! 1D: constant Bx; By, Bz as variables B%L(1) = Bx0 B%R(1) = Bx0 B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) - else ! 2D/3D: Bx, By, Bz as variables + else ! 2D/3D: Bx, By, Bz as variables B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) @@ -1126,10 +1124,10 @@ contains pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R & - & + pres_mag%R ! includes magnetic energy + & + pres_mag%R ! includes magnetic energy H_L = (E_L + pres_L - pres_mag%L)/rho_L H_R = (E_R + pres_R - pres_mag%R) & - & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 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 @@ -1318,7 +1316,7 @@ contains ! Elastic Stresses if (hypoelasticity) then - do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow + do i = 1, strxe - strxb + 1 ! TODO: this indexing may be slow flux_rs${XYZ}$_vf(j, k, l, & & strxb - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & @@ -1357,7 +1355,7 @@ contains ! MHD: magnetic flux and Maxwell stress contributions if (mhd) then - if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. + 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 @@ -1366,7 +1364,7 @@ contains & - 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 + 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}$) @@ -1785,7 +1783,7 @@ contains 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, xi_R !< Left and right wave speeds functions real(wp) :: xi_M, xi_P real(wp) :: xi_MP, xi_PP #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -1817,14 +1815,13 @@ contains 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 + 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, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction @@ -1976,7 +1973,7 @@ contains xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) end do - G_L = 0._wp; G_R = 0._wp; + G_L = 0._wp; G_R = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_fluids ! Mixture left and right shear modulus @@ -2121,7 +2118,7 @@ contains ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux if (elasticity) then - flux_ene_e = 0._wp; + flux_ene_e = 0._wp $:GPU_LOOP(parallelism='[seq]') do i = 1, num_dims ! MOMENTUM ELASTIC FLUX. @@ -2392,7 +2389,7 @@ contains flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0._wp $:GPU_LOOP(parallelism='[seq]') - do i = alf_idx, alf_idx ! only advect the void fraction + do i = alf_idx, alf_idx ! only advect the void fraction flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, & & i)*(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) + xi_P*qR_prim_rs${XYZ}$_vf(j & & + 1, k, l, i)*(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) @@ -2533,7 +2530,7 @@ contains end if if (viscous) then - if (num_fluids == 1) then ! Need to consider case with num_fluids >= 2 + 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 @@ -3389,9 +3386,8 @@ contains integer :: i, j, k, l call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, & - & qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, & - & norm_dir, ix, iy, iz) + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & + & dqR_prim_dz_vf, norm_dir, ix, iy, iz) call s_initialize_riemann_solver(flux_src_vf, norm_dir) @@ -3431,12 +3427,12 @@ contains ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated + if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, & & B_idx%beg + 1)] B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, & & B_idx%beg + 1)] - else ! 2D/3D: Bx, By, Bz as variables + else ! 2D/3D: Bx, By, Bz as variables B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), qL_prim_rs${XYZ}$_vf(j, k, & & l, B_idx%beg + dir_idx(2) - 1), qL_prim_rs${XYZ}$_vf(j, k, l, & & B_idx%beg + dir_idx(3) - 1)] @@ -3465,10 +3461,10 @@ contains 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 + E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L H_no_mag%R = (E%R + pres%R - pres_mag%R) & - & /rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + & /rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) ! (2) Compute fast wave speeds call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, & @@ -3560,8 +3556,8 @@ contains F_hlld = F_R end if - ! (12) Reorder and write temporary variables to the flux array Mass - flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component + ! (12) Write HLLD flux to output arrays + flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component ! Momentum flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = F_hlld(2) flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(2)) = F_hlld(3) @@ -3576,10 +3572,10 @@ contains end if ! Energy flux_rs${XYZ}$_vf(j, k, l, E_idx) = F_hlld(7) - ! Partial fraction + ! Volume fractions $:GPU_LOOP(parallelism='[seq]') do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = 0._wp ! TODO multi-component (zero for now) + flux_rs${XYZ}$_vf(j, k, l, i) = 0._wp ! TODO multi-component (zero for now) end do flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -3708,7 +3704,7 @@ contains integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: i, j, k, l !< Generic loop iterator + integer :: i, j, k, l !< Generic loop iterator if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz @@ -3741,7 +3737,7 @@ contains ! 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 + 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 @@ -3789,7 +3785,7 @@ contains end if end if - if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end $:GPU_PARALLEL_LOOP(collapse=3) do i = 1, sys_size @@ -3841,7 +3837,7 @@ contains ! 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 + 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 @@ -3887,7 +3883,7 @@ contains end if end if - if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end $:GPU_PARALLEL_LOOP(collapse=3) do i = 1, sys_size @@ -3937,7 +3933,7 @@ contains ! Population of Buffers in z-direction else - if (bc_z%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + 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 l = is3%beg, is3%end @@ -3979,7 +3975,7 @@ contains end if end if - if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end $:GPU_PARALLEL_LOOP(collapse=3) do i = 1, sys_size @@ -4036,7 +4032,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf integer, intent(in) :: norm_dir - integer :: i, j, k, l ! Generic loop iterators + integer :: i, j, k, l ! Generic loop iterators ! Reshaping Inputted Data in x-direction @@ -4274,17 +4270,17 @@ contains ! Get Re numbers and interface velocity for viscous work select case (norm_dir) - case (1) ! x-face (axial face in z_cyl direction) + case (1) ! x-face (axial face in z_cyl direction) Re_s = Re_avg_rsx_vf(j, k, l, 1) Re_b = Re_avg_rsx_vf(j, k, l, 2) vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) r_eff = y_cc(k) - case (2) ! y-face (radial face in r_cyl direction) + case (2) ! y-face (radial face in r_cyl direction) Re_s = Re_avg_rsy_vf(k, j, l, 1) Re_b = Re_avg_rsy_vf(k, j, l, 2) vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) r_eff = y_cb(k) - case (3) ! z-face (azimuthal face in theta_cyl direction) + case (3) ! z-face (azimuthal face in theta_cyl direction) Re_s = Re_avg_rsz_vf(l, k, j, 1) Re_b = Re_avg_rsz_vf(l, k, j, 2) vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) @@ -4308,7 +4304,7 @@ contains 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) + 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 @@ -4320,7 +4316,7 @@ contains 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) + 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 @@ -4335,7 +4331,7 @@ contains 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) + 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 @@ -4393,25 +4389,25 @@ contains ! 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. + 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. + 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. + 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. $: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]') @@ -4523,8 +4519,8 @@ contains 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. + 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 @@ -4556,7 +4552,7 @@ contains #:endif ! Local variables - integer :: i_dim !< Loop iterator for diagonal components. + integer :: i_dim !< Loop iterator for diagonal components. tau_bulk_out = 0.0_wp do i_dim = 1, num_dims @@ -4574,7 +4570,7 @@ contains 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 + integer :: i, j, k, l !< Generic loop iterators ! Reshaping Outputted Data in y-direction if (norm_dir == 2) then diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 65d79ac804..9f752c17c3 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -77,7 +77,7 @@ contains impure subroutine s_read_input_file character(LEN=name_len), parameter :: file_path = './simulation.inp' - logical :: file_exist !< Logical used to check the existence of the input file + logical :: file_exist !< Logical used to check the existence of the input file integer :: iostatus !! Integer to check iostat of file read @@ -175,8 +175,8 @@ contains impure subroutine s_read_serial_data_files(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the starting time-step directory - character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files + character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the starting time-step directory + character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files logical :: file_exist integer :: i, r @@ -320,7 +320,7 @@ contains ! Downsampled data variables integer :: m_ds, n_ds, p_ds integer :: m_glb_ds, n_glb_ds, p_glb_ds - integer :: m_glb_read, n_glb_read, p_glb_read ! data size of read + integer :: m_glb_read, n_glb_read, p_glb_read ! data size of read allocate (x_cb_glb(-1:m_glb)) allocate (y_cb_glb(-1:n_glb)) @@ -443,7 +443,7 @@ contains NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) if (bubbles_euler .or. elasticity) then - do i = 1, sys_size ! adv_idx%end + do i = 1, sys_size ! adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) call MPI_FILE_READ(ifile, MPI_IO_DATA%var(i)%sf, data_size*mpi_io_type, mpi_io_p, status, ierr) @@ -507,7 +507,7 @@ contains NVARS_MOK = int(sys_size, MPI_OFFSET_KIND) if (bubbles_euler .or. elasticity) then - do i = 1, sys_size ! adv_idx%end + do i = 1, sys_size ! adv_idx%end var_MOK = int(i, MPI_OFFSET_KIND) disp = m_MOK*max(MOK, n_MOK)*max(MOK, p_MOK)*WP_MOK*(var_MOK - 1) @@ -647,11 +647,14 @@ contains if (cfl_dt) then if (proc_rank == 0 .and. mod(t_step - t_step_start, t_step_print) == 0) then - print '(" [", I3, "%] Time ", ES16.6, " dt = ", ES16.6, " @ Time Step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', int(ceiling(100._wp*(mytime/t_stop))), mytime, dt, t_step, wall_time_avg, wall_time + print '(" [", I3, "%] Time ", ES16.6, " dt = ", ES16.6, " @ Time Step = ", I8, " Time Avg = ", ES16.6, " Time/step = ", ES12.6, "")', & + & int(ceiling(100._wp*(mytime/t_stop))), mytime, dt, t_step, wall_time_avg, wall_time end if else if (proc_rank == 0 .and. mod(t_step - t_step_start, t_step_print) == 0) then - print '(" [", I3, "%] Time step ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES12.6, " Time/step= ", ES12.6, "")', int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), t_step - t_step_start + 1, t_step_stop - t_step_start + 1, t_step, wall_time_avg, wall_time + print '(" [", I3, "%] Time step ", I8, " of ", I0, " @ t_step = ", I8, " Time Avg = ", ES12.6, " Time/step= ", ES12.6, "")', & + & int(ceiling(100._wp*(real(t_step - t_step_start)/(t_step_stop - t_step_start + 1)))), & + & t_step - t_step_start + 1, t_step_stop - t_step_start + 1, t_step, wall_time_avg, wall_time end if end if @@ -809,7 +812,7 @@ contains $:GPU_UPDATE(host='[q_beta(1)%sf]') call s_write_data_files(q_cons_ts(stor)%vf, q_T_sf, q_prim_vf, save_count, bc_type, q_beta(1)) $:GPU_UPDATE(host='[Rmax_stats, Rmin_stats, gas_p, gas_mv, intfc_vel]') - call s_write_restart_lag_bubbles(save_count) ! parallel + call s_write_restart_lag_bubbles(save_count) ! parallel if (lag_params%write_bubbles_stats) call s_write_lag_bubble_stats() else call s_write_data_files(q_cons_ts(stor)%vf, q_T_sf, q_prim_vf, save_count, bc_type) diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index b32368db0c..a8525630b2 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -298,7 +298,7 @@ contains real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(out) :: vL_x, vL_y, vL_z real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(out) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir - integer :: recon_dir !< Coordinate direction of the reconstruction + integer :: recon_dir !< Coordinate direction of the reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno', 'WENO_TYPE'),('muscl', 'MUSCL_TYPE')] diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 80e3240e58..72b38eb486 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -29,18 +29,18 @@ module m_time_steppers implicit none - type(vector_field), allocatable, dimension(:) :: q_cons_ts !< Cell-average conservative variables at each time-stage (TS) - type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< Cell-average primitive variables at the current time-stage - type(scalar_field), allocatable, dimension(:) :: rhs_vf !< Cell-average RHS variables at the current time-stage - type(integer_field), allocatable, dimension(:,:) :: bc_type !< Boundary condition identifiers + type(vector_field), allocatable, dimension(:) :: q_cons_ts !< Cell-average conservative variables at each time-stage (TS) + type(scalar_field), allocatable, dimension(:) :: q_prim_vf !< Cell-average primitive variables at the current time-stage + type(scalar_field), allocatable, dimension(:) :: rhs_vf !< Cell-average RHS variables at the current time-stage + type(integer_field), allocatable, dimension(:,:) :: bc_type !< Boundary condition identifiers !> Cell-average primitive variables at consecutive TIMESTEPS type(vector_field), allocatable, dimension(:) :: q_prim_ts1, q_prim_ts2 real(wp), allocatable, dimension(:,:,:,:,:) :: rhs_pb - type(scalar_field) :: q_T_sf !< Cell-average temperature variables at the current time-stage + type(scalar_field) :: q_T_sf !< Cell-average temperature variables at the current time-stage real(wp), allocatable, dimension(:,:,:,:,:) :: rhs_mv real(wp), allocatable, dimension(:,:,:) :: max_dt - integer, private :: num_ts !< Number of time stages in the time-stepping scheme - integer :: stor !< storage index + integer, private :: num_ts !< Number of time stages in the time-stepping scheme + integer :: stor !< storage index real(wp), allocatable, dimension(:,:) :: rk_coef integer, private :: num_probe_ts @@ -71,7 +71,7 @@ contains use openacc #endif #endif - integer :: i, j !< Generic loop iterators + integer :: i, j !< Generic loop iterators ! Setting number of time-stages for selected time-stepping scheme if (time_stepper == 1) then @@ -462,7 +462,7 @@ contains integer, intent(in) :: t_step real(wp), intent(inout) :: time_avg integer, intent(in) :: nstage - integer :: i, j, k, l, q, s !< Generic loop iterator + integer :: i, j, k, l, q, s !< Generic loop iterator real(wp) :: start, finish integer :: dest @@ -628,26 +628,26 @@ contains !> @brief Computes the global time step size from CFL stability constraints across all cells. impure subroutine s_compute_dt() - real(wp) :: rho !< Cell-avg. density + real(wp) :: rho !< Cell-avg. density #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: vel !< Cell-avg. velocity - real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction + real(wp), dimension(3) :: vel !< Cell-avg. velocity + real(wp), dimension(3) :: alpha !< Cell-avg. volume fraction #:else - real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity - real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction + real(wp), dimension(num_vels) :: vel !< Cell-avg. velocity + real(wp), dimension(num_fluids) :: alpha !< Cell-avg. volume fraction #:endif - real(wp) :: vel_sum !< Cell-avg. velocity sum - real(wp) :: pres !< Cell-avg. pressure - real(wp) :: gamma !< Cell-avg. sp. heat ratio - real(wp) :: pi_inf !< Cell-avg. liquid stiffness function - real(wp) :: qv !< Cell-avg. fluid reference energy - real(wp) :: c !< Cell-avg. sound speed - real(wp) :: H !< Cell-avg. enthalpy - real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers + real(wp) :: vel_sum !< Cell-avg. velocity sum + real(wp) :: pres !< Cell-avg. pressure + real(wp) :: gamma !< Cell-avg. sp. heat ratio + real(wp) :: pi_inf !< Cell-avg. liquid stiffness function + real(wp) :: qv !< Cell-avg. fluid reference energy + real(wp) :: c !< Cell-avg. sound speed + real(wp) :: H !< Cell-avg. enthalpy + real(wp), dimension(2) :: Re !< Cell-avg. Reynolds numbers type(vector_field) :: gm_alpha_qp real(wp) :: dt_local - integer :: j, k, l !< Generic loop iterators + integer :: j, k, l !< Generic loop iterators if (.not. igr .or. dummy) then call s_convert_conservative_to_primitive_variables(q_cons_ts(1)%vf, q_T_sf, q_prim_vf, idwint) @@ -695,7 +695,7 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_cons_vf type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf_in type(scalar_field), dimension(1:sys_size), intent(inout) :: rhs_vf_in - real(wp), intent(in) :: ldt !< local dt + real(wp), intent(in) :: ldt !< local dt integer :: i, j, k, l call nvtxStartRange("RHS-BODYFORCES") @@ -746,7 +746,7 @@ contains if (patch_ib(i)%moving_ibm == 1) then ! plug in analytic velocities for 1-way coupling, if it exists @:mib_analytical() - else if (patch_ib(i)%moving_ibm == 2) then ! if we are using two-way coupling, apply force and torque + else if (patch_ib(i)%moving_ibm == 2) then ! if we are using two-way coupling, apply force and torque ! compute the force and torque on the IB from the fluid if (.not. forces_computed) then call s_compute_ib_forces(q_prim_vf, fluid_pp) @@ -758,11 +758,11 @@ contains ! update the angular velocity with the torque value patch_ib(i)%angular_vel = (patch_ib(i)%angular_vel*patch_ib(i)%moment) + (rk_coef(s, & - & 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum + & 3)*dt*patch_ib(i)%torque/rk_coef(s, 4)) ! add the torque to the angular momentum call s_compute_moment_of_inertia(i, patch_ib(i)%angular_vel) ! update the moment of inertia to be based on the direction of the angular momentum patch_ib(i)%angular_vel = patch_ib(i)%angular_vel/patch_ib(i) & - & %moment ! convert back to angular velocity with the new moment of inertia + & %moment ! convert back to angular velocity with the new moment of inertia end if ! Update the angle of the IB @@ -790,7 +790,7 @@ contains subroutine s_time_step_cycling(t_step) integer, intent(in) :: t_step - integer :: i, j, k, l !< Generic loop iterator + integer :: i, j, k, l !< Generic loop iterator if (t_step == t_step_start) then $:GPU_PARALLEL_LOOP(collapse=4) @@ -840,7 +840,7 @@ contains end do end do $:END_GPU_PARALLEL_LOOP() - else ! All other timesteps + else ! All other timesteps $:GPU_PARALLEL_LOOP(collapse=4) do i = 1, sys_size do l = 0, p @@ -867,7 +867,7 @@ contains use hipfort_hipmalloc use hipfort_check #endif - integer :: i, j !< Generic loop iterators + integer :: i, j !< Generic loop iterators ! Deallocating the cell-average conservative variables #if defined(__NVCOMPILER_GPU_UNIFIED_MEM) do j = 1, sys_size diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 6ebbec844b..4b1c402205 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -29,7 +29,7 @@ contains !> @brief Allocates and populates the viscous Reynolds number arrays and transfers data to the GPU. impure subroutine s_initialize_viscous_module - integer :: i, j !< generic loop iterators + integer :: i, j !< generic loop iterators @:ALLOCATE(Res_viscous(1:2, 1:Re_size_max)) @@ -54,7 +54,7 @@ contains type(scalar_field), dimension(num_dims), intent(in) :: grad_x_vf, grad_y_vf, grad_z_vf type(scalar_field), dimension(1:sys_size), intent(inout) :: tau_Re_vf type(int_bounds_info), intent(in) :: ix, iy, iz - real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables + real(wp) :: rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum !< Mixture variables real(wp), dimension(2) :: Re_visc #:if not MFC_CASE_OPTIMIZATION and USING_AMD @@ -65,7 +65,7 @@ contains real(wp), dimension(num_dims, num_dims) :: tau_Re #:endif - integer :: i, j, k, l, q !< Generic loop iterator + integer :: i, j, k, l, q !< Generic loop iterator is1_viscous = ix; is2_viscous = iy; is3_viscous = iz @@ -85,7 +85,7 @@ contains $:END_GPU_PARALLEL_LOOP() #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (shear_stress) then ! Shear stresses + if (shear_stress) then ! Shear stresses $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end @@ -187,7 +187,7 @@ contains #:endif #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (bulk_stress) then ! Bulk stresses + if (bulk_stress) then ! Bulk stresses $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end @@ -284,7 +284,7 @@ contains if (p == 0) return #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (shear_stress) then ! Shear stresses + if (shear_stress) then ! Shear stresses $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end @@ -383,7 +383,7 @@ contains $:END_GPU_PARALLEL_LOOP() end if - if (bulk_stress) then ! Bulk stresses + if (bulk_stress) then ! Bulk stresses $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, rho_visc, gamma_visc, pi_inf_visc, alpha_visc_sum, & & alpha_visc, alpha_rho_visc, Re_visc, tau_Re]') do l = is3_viscous%beg, is3_viscous%end @@ -524,8 +524,8 @@ contains $:GPU_UPDATE(device='[iv]') call s_reconstruct_cell_boundary_values_visc(q_prim_qp%vf(iv%beg:iv%end), qL_prim_rsx_vf, qL_prim_rsy_vf, & - & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, i, & - & qL_prim(i)%vf(iv%beg:iv%end), qR_prim(i)%vf(iv%beg:iv%end), ix, iy, iz) + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, i, qL_prim(i)%vf(iv%beg:iv%end), & + & qR_prim(i)%vf(iv%beg:iv%end), ix, iy, iz) end do if (weno_Re_flux) then @@ -545,7 +545,7 @@ contains & buff_size) end if end do - else ! Compute velocity gradients at cell centers using central finite differences + else ! Compute velocity gradients at cell centers using central finite differences iv%beg = mom_idx%beg; iv%end = mom_idx%end $:GPU_UPDATE(device='[iv]') @@ -881,7 +881,7 @@ contains & vR_y, vR_z integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: recon_dir !< Coordinate direction of the WENO reconstruction + integer :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] @@ -978,7 +978,7 @@ contains type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf type(int_bounds_info), intent(in) :: ix, iy, iz integer, intent(in) :: norm_dir - integer :: recon_dir !< Coordinate direction of the WENO reconstruction + integer :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] @@ -1087,7 +1087,7 @@ contains type(int_bounds_info), intent(in) :: ix, iy, iz, iv_in integer, intent(in) :: dim, buff_size_in real(wp), dimension(-buff_size_in:dim + buff_size_in), intent(in) :: dL - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators is1_viscous = ix is2_viscous = iy @@ -1176,7 +1176,7 @@ contains type(scalar_field), intent(inout) :: grad_y type(scalar_field), intent(inout) :: grad_z type(int_bounds_info) :: ix, iy, iz - integer :: j, k, l !< Generic loop iterators + integer :: j, k, l !< Generic loop iterators ix%beg = 1 - buff_size; ix%end = m + buff_size - 1 if (n > 0) then @@ -1343,7 +1343,7 @@ contains real(wp), dimension(1:3, 1:3) :: velocity_gradient_tensor real(wp), dimension(1:3) :: dx real(wp) :: divergence - integer :: l, q ! iterators + integer :: l, q ! iterators ! zero the viscous stress, collection of velocity derivatives, and spatial finite differences viscous_stress_tensor = 0._wp diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index a61d49f0f8..bc9167ea88 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -68,7 +68,7 @@ module m_weno ! END: WENO Coefficients - integer :: v_size !< Number of WENO-reconstructed cell-average variables + integer :: v_size !< Number of WENO-reconstructed cell-average variables $:GPU_DECLARE(create='[v_size]') !> @name Indical bounds in the s1-, s2- and s3-directions @@ -93,7 +93,7 @@ contains if (n == 0) then is2_weno%beg = 0 else - is2_weno%beg = -buff_size; + is2_weno%beg = -buff_size end if is2_weno%end = n - is2_weno%beg @@ -181,11 +181,11 @@ contains integer, intent(in) :: weno_dir type(int_bounds_info), intent(in) :: is integer :: s - real(wp), pointer, dimension(:) :: s_cb => null() !< Cell-boundary locations in the s-direction - type(int_bounds_info) :: bc_s !< Boundary conditions (BC) in the s-direction - integer :: i !< Generic loop iterator - real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil - real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil + real(wp), pointer, dimension(:) :: s_cb => null() !< Cell-boundary locations in the s-direction + type(int_bounds_info) :: bc_s !< Boundary conditions (BC) in the s-direction + integer :: i !< Generic loop iterator + real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil + real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil ! Determine cell count, boundary locations, and BCs for selected WENO direction @@ -366,7 +366,7 @@ contains d_cbL_${XYZ}$ (0:1, s) = 0._wp; d_cbL_${XYZ}$ (2, s) = 1._wp end if end if - else ! WENO7 + else ! WENO7 if (.not. teno) then do i = is%beg - 1 + weno_polyn, is%end - 1 - weno_polyn ! Reference: Shu (1997) "Essentially Non-Oscillatory and Weighted Essentially Non-Oscillatory Schemes @@ -381,7 +381,7 @@ contains ! (dvd) instead of the values themselves. While the polynomial coefficients sum to 1, the derivative of ! 1 is 0, which means it does not create additional cross terms in the smoothness indicators. - w = s_cb(i - 3:i + 4) - s_cb(i) ! Offset using s_cb(i) to reduce floating point error + w = s_cb(i - 3:i + 4) - s_cb(i) ! Offset using s_cb(i) to reduce floating point error d_cbR_${XYZ}$ (0, & & i + 1) = ((w(5) - w(6))*(w(5) - w(7))*(w(5) - w(8)))/((w(1) - w(6))*(w(1) - w(7)) & & *(w(1) - w(8))) @@ -828,7 +828,7 @@ contains & + 5*y(3)**2*y(4)**2))/(5*(y(1) + y(2))**2*(y(1) + y(2) + y(3))**2*(y(1) + y(2) & & + y(3) + y(4))**2) end do - else ! TENO (only supports uniform grid) + else ! TENO (only supports uniform grid) ! (Fu, et al., 2016) Table 2 (for right flux) d_cbL_${XYZ}$ (0,:) = 18._wp/35._wp d_cbL_${XYZ}$ (1,:) = 3._wp/35._wp @@ -888,7 +888,7 @@ contains real(wp), dimension(0:weno_num_stencils) :: beta real(wp), dimension(0:weno_num_stencils) :: delta #:endif - real(wp), dimension(-3:3) :: v ! temporary field value array for clarity (WENO7 only) + real(wp), dimension(-3:3) :: v ! temporary field value array for clarity (WENO7 only) real(wp) :: tau integer :: i, j, k, l, q @@ -1078,7 +1078,7 @@ contains else if (wenoz) then ! Borges, et al. (2008) - tau = abs(beta(2) - beta(0)) ! Equation 25 + tau = abs(beta(2) - beta(0)) ! Equation 25 $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbL_${XYZ}$ (q, j)*(1._wp + (tau/beta(q))) @@ -1089,20 +1089,20 @@ contains tau = abs(beta(2) - beta(0)) $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - alpha(q) = 1._wp + tau/beta(q) ! Equation 22 (reuse alpha as gamma; pick C=1 & q=6) + alpha(q) = 1._wp + tau/beta(q) ! Equation 22 (reuse alpha as gamma; pick C=1 & q=6) alpha(q) = (alpha(q)**3._wp) & - & **2._wp ! Equation 22 cont. (some CPU compilers cannot optimize x**6.0) + & **2._wp ! Equation 22 cont. (some CPU compilers cannot optimize x**6.0) end do - omega = alpha/sum(alpha) ! Equation 25 (reuse omega as xi) + omega = alpha/sum(alpha) ! Equation 25 (reuse omega as xi) $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - if (omega(q) < teno_CT) then ! Equation 26 + if (omega(q) < teno_CT) then ! Equation 26 delta(q) = 0._wp else delta(q) = 1._wp end if - alpha(q) = delta(q)*d_cbL_${XYZ}$ (q, j) ! Equation 27 + alpha(q) = delta(q)*d_cbL_${XYZ}$ (q, j) ! Equation 27 end do end if @@ -1176,7 +1176,7 @@ contains beta(:) = weno_eps if (teno) v = v_rs_ws_${XYZ}$ (j - 3:j + 3, k, l, & - & i) ! temporary field value array for clarity + & i) ! temporary field value array for clarity if (.not. teno) then dvd(2) = v_rs_ws_${XYZ}$ (j + 3, k, l, i) - v_rs_ws_${XYZ}$ (j + 2, k, l, i) @@ -1236,7 +1236,7 @@ contains & 2)*dvd(-1)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, & & 3)*dvd(-2)*dvd(-2) + beta_coef_${XYZ}$ (j, 3, & & 4)*dvd(-2)*dvd(-3) + beta_coef_${XYZ}$ (j, 3, 5)*dvd(-3)*dvd(-3) + weno_eps - else ! TENO + else ! TENO #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 ! High-Order Low-Dissipation Targeted ENO Schemes for Ideal Magnetohydrodynamics (Fu ! & Tang, 2019) Section 3.2 @@ -1272,27 +1272,27 @@ contains & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) else if (wenoz) then ! Castro, et al. (2010) Don & Borges (2013) also helps - tau = abs(beta(3) - beta(0)) ! Equation 50 + tau = abs(beta(3) - beta(0)) ! Equation 50 $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbL_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability + & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability end do else if (teno) then #:if not MFC_CASE_OPTIMIZATION or weno_num_stencils > 3 - tau = abs(beta(4) - beta(3)) ! Note the reordering of stencils + tau = abs(beta(4) - beta(3)) ! Note the reordering of stencils alpha = 1._wp + tau/beta - alpha = (alpha**3._wp)**2._wp ! some CPU compilers cannot optimize x**6.0 + alpha = (alpha**3._wp)**2._wp ! some CPU compilers cannot optimize x**6.0 omega = alpha/sum(alpha) $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils - if (omega(q) < teno_CT) then ! Equation 26 + if (omega(q) < teno_CT) then ! Equation 26 delta(q) = 0._wp else delta(q) = 1._wp end if - alpha(q) = delta(q)*d_cbL_${XYZ}$ (q, j) ! Equation 27 + alpha(q) = delta(q)*d_cbL_${XYZ}$ (q, j) ! Equation 27 end do #:endif end if @@ -1349,7 +1349,7 @@ contains $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils alpha(q) = d_cbR_${XYZ}$ (q, & - & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability + & j)*(1._wp + (tau/beta(q))**wenoz_q) ! wenoz_q = 2,3,4 for stability end do else if (teno) then $:GPU_LOOP(parallelism='[seq]') @@ -1462,8 +1462,8 @@ contains real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: v_rs_ws real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf, vR_rs_vf integer :: i, j, k, l - real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers - real(wp) :: d_MD, d_LC !< Median (md) curvature and large curvature (LC) measures + real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers + real(wp) :: d_MD, d_LC !< Median (md) curvature and large curvature (LC) measures ! The left and right upper bounds (UL), medians, large curvatures, minima, and maxima of the WENO-reconstructed values of ! the cell- average variables. real(wp) :: vL_UL, vR_UL @@ -1562,7 +1562,6 @@ contains ! Deallocating the WENO-stencil of the WENO-reconstructed variables - ! deallocate(vL_rs_vf_x, vR_rs_vf_x) @:DEALLOCATE(v_rs_ws_x) ! Deallocating WENO coefficients in x-direction @@ -1573,7 +1572,6 @@ contains ! Deallocating WENO coefficients in y-direction if (n == 0) return - ! deallocate(vL_rs_vf_y, vR_rs_vf_y) @:DEALLOCATE(v_rs_ws_y) @:DEALLOCATE(poly_coef_cbL_y, poly_coef_cbR_y) @@ -1583,7 +1581,6 @@ contains ! Deallocating WENO coefficients in z-direction if (p == 0) return - ! deallocate(vL_rs_vf_z, vR_rs_vf_z) @:DEALLOCATE(v_rs_ws_z) @:DEALLOCATE(poly_coef_cbL_z, poly_coef_cbR_z) diff --git a/src/simulation/p_main.fpp b/src/simulation/p_main.fpp index 86f7e82eba..1d0ad72035 100644 --- a/src/simulation/p_main.fpp +++ b/src/simulation/p_main.fpp @@ -17,7 +17,7 @@ program p_main implicit none - integer :: t_step !< Iterator for the time-stepping loop + integer :: t_step !< Iterator for the time-stepping loop real(wp) :: time_avg, time_final real(wp) :: io_time_avg, io_time_final real(wp), allocatable, dimension(:) :: proc_time @@ -61,7 +61,7 @@ program p_main finaltime = t_step_stop*dt end if - call nvtxEndRange ! INIT + call nvtxEndRange ! INIT call nvtxStartRange("SIMULATION-TIME-MARCH") ! Time-stepping Loop @@ -95,7 +95,7 @@ program p_main call system_clock(cpu_end) end do - call nvtxEndRange ! Simulation + call nvtxEndRange ! Simulation deallocate (proc_time, io_proc_time) From 17b6fdd230e60a08ef4547f06edf5df091a2e6cf Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 19:04:31 -0400 Subject: [PATCH 21/25] Standardize Doxygen: remove obvious @param, clean verbose headers, consistent style --- src/common/include/1dHardcodedIC.fpp | 8 +- src/common/include/2dHardcodedIC.fpp | 10 +- src/common/include/3dHardcodedIC.fpp | 4 +- src/common/include/ExtrusionHardcodedIC.fpp | 2 +- src/common/include/macros.fpp | 7 +- src/common/m_boundary_common.fpp | 53 +++--- src/common/m_checker_common.fpp | 4 +- src/common/m_chemistry.fpp | 10 +- src/common/m_compile_specific.f90 | 9 +- src/common/m_delay_file_access.f90 | 2 +- src/common/m_finite_differences.fpp | 9 +- src/common/m_helper.fpp | 90 +++-------- src/common/m_helper_basic.fpp | 18 +-- src/common/m_model.fpp | 92 +++-------- src/common/m_mpi_common.fpp | 70 ++------ src/common/m_nvtx.f90 | 4 +- src/common/m_phase_change.fpp | 51 ++---- src/common/m_variables_conversion.fpp | 91 ++--------- src/post_process/m_data_input.f90 | 29 +--- src/post_process/m_data_output.fpp | 35 ++-- src/post_process/m_derived_variables.fpp | 48 ++---- src/post_process/m_mpi_proxy.fpp | 22 ++- src/post_process/m_start_up.fpp | 16 +- src/post_process/p_main.fpp | 8 +- src/pre_process/m_assign_variables.fpp | 45 ++---- src/pre_process/m_boundary_conditions.fpp | 8 +- src/pre_process/m_check_ib_patches.fpp | 38 ++--- src/pre_process/m_check_patches.fpp | 56 +++---- src/pre_process/m_data_output.fpp | 7 - src/pre_process/m_global_parameters.fpp | 4 +- src/pre_process/m_grid.f90 | 10 +- src/pre_process/m_icpp_patches.fpp | 63 +------- src/pre_process/m_initial_condition.fpp | 6 +- src/pre_process/m_perturbation.fpp | 25 ++- src/pre_process/m_simplex_noise.fpp | 6 +- src/pre_process/m_start_up.fpp | 19 +-- src/pre_process/p_main.f90 | 2 +- src/simulation/m_acoustic_src.fpp | 61 ++----- src/simulation/m_body_forces.fpp | 14 +- src/simulation/m_bubbles.fpp | 170 +------------------- src/simulation/m_bubbles_EE.fpp | 12 +- src/simulation/m_bubbles_EL.fpp | 86 +++------- src/simulation/m_bubbles_EL_kernels.fpp | 39 +---- src/simulation/m_cbc.fpp | 36 +---- src/simulation/m_checker.fpp | 2 +- src/simulation/m_compute_levelset.fpp | 20 +-- src/simulation/m_data_output.fpp | 58 ++----- src/simulation/m_derived_variables.fpp | 20 +-- src/simulation/m_fftw.fpp | 10 +- src/simulation/m_global_parameters.fpp | 3 +- src/simulation/m_hyperelastic.fpp | 32 +--- src/simulation/m_hypoelastic.fpp | 11 +- src/simulation/m_ib_patches.fpp | 71 ++------ src/simulation/m_ibm.fpp | 42 ++--- src/simulation/m_igr.fpp | 15 +- src/simulation/m_mpi_proxy.fpp | 6 +- src/simulation/m_muscl.fpp | 8 +- src/simulation/m_pressure_relaxation.fpp | 1 - src/simulation/m_qbmm.fpp | 20 +-- src/simulation/m_rhs.fpp | 24 +-- src/simulation/m_riemann_solvers.fpp | 114 +------------ src/simulation/m_sim_helpers.fpp | 41 ----- src/simulation/m_start_up.fpp | 31 ++-- src/simulation/m_surface_tension.fpp | 8 +- src/simulation/m_time_steppers.fpp | 18 +-- src/simulation/m_viscous.fpp | 54 +------ src/simulation/m_weno.fpp | 22 +-- 67 files changed, 488 insertions(+), 1542 deletions(-) diff --git a/src/common/include/1dHardcodedIC.fpp b/src/common/include/1dHardcodedIC.fpp index 80b7e9edcb..562005ac32 100644 --- a/src/common/include/1dHardcodedIC.fpp +++ b/src/common/include/1dHardcodedIC.fpp @@ -13,21 +13,21 @@ ! magnetic field q_prim_vf(B_idx%end - 1)%sf(i, 0, 0) = 0.1_wp*sin(2._wp*pi*x_cc(i)) q_prim_vf(B_idx%end)%sf(i, 0, 0) = 0.1_wp*cos(2._wp*pi*x_cc(i)) - case (170) + case (170) ! 1D profile from external data (e.g. Cantera, SDtoolbox) ! This hardcoded case can be used to start a simulation with initial conditions given from a known 1D profile (e.g. Cantera, ! SDtoolbox) @: HardcodedReadValues() - case (180) + case (180) ! Shu-Osher problem ! This is patch is hard-coded for test suite optimization used in the 1D_shuoser cases: "patch_icpp(2)%alpha_rho(1)": "1 + ! 0.2*sin(5*x)" if (patch_id == 2) then q_prim_vf(contxb + 0)%sf(i, 0, 0) = 1 + 0.2*sin(5*x_cc(i)) end if - case (181) + case (181) ! Titarev-Torro problem ! This is patch is hard-coded for test suite optimization used in the 1D_titarevtorro cases: "patch_icpp(2)%alpha_rho(1)": ! "1 + 0.1*sin(20*x*pi)" q_prim_vf(contxb + 0)%sf(i, 0, 0) = 1 + 0.1*sin(20*x_cc(i)*pi) - case (182) + case (182) ! Multi-component diffusion ! This patch is a hard-coded for test suite optimization (multiple component diffusion) x_mid_diffu = 0.05_wp/2.0_wp width_sq = (2.5_wp*10.0_wp**(-3.0_wp))**2 diff --git a/src/common/include/2dHardcodedIC.fpp b/src/common/include/2dHardcodedIC.fpp index abbe4b172e..b2752228f0 100644 --- a/src/common/include/2dHardcodedIC.fpp +++ b/src/common/include/2dHardcodedIC.fpp @@ -18,7 +18,7 @@ #:def Hardcoded2D() select case (patch_icpp(patch_id)%hcid) ! 2D_hardcoded_ic example case - case (200) + case (200) ! Two-fluid cubic interface if (y_cc(j) <= (-x_cc(i)**3 + 1)**(1._wp/3._wp)) then ! Volume Fractions q_prim_vf(advxb)%sf(i, j, 0) = eps @@ -263,10 +263,10 @@ q_prim_vf(B_idx%beg + 1)%sf(i, j, 0) = (5._wp/sqrt(4._wp*pi))*sinA + (5._wp/sqrt(4._wp*pi))*cosA end if ! v^z and B^z remain zero by default - case (270) + case (270) ! 2D extrusion of 1D profile from external data ! This hardcoded case extrudes a 1D profile to initialize a 2D simulation domain @: HardcodedReadValues() - case (280) + case (280) ! Isentropic vortex ! This is patch is hard-coded for test suite optimization used in the 2D_isentropicvortex case: This analytic patch uses ! geometry 2 if (patch_id == 1) then @@ -283,7 +283,7 @@ & 0) = 0.0 - (x_cc(i) - patch_icpp(1)%x_centroid)*(5.0/(2.0*pi))*exp(1.0*(1.0 - (x_cc(i) - patch_icpp(1) & & %x_centroid)**2.0 - (y_cc(j) - patch_icpp(1)%y_centroid)**2.0)) end if - case (281) + case (281) ! Acoustic pulse ! This is patch is hard-coded for test suite optimization used in the 2D_acoustic_pulse case: This analytic patch uses ! geometry 2 if (patch_id == 2) then @@ -292,7 +292,7 @@ q_prim_vf(contxb + 0)%sf(i, j, & & 0) = 1*(1 - 0.5*(1.4 - 1)*(0.4)**2*exp(0.5*(1 - sqrt(x_cc(i)**2 + y_cc(j)**2))))**(1/(1.4 - 1)) end if - case (282) + case (282) ! Zero-circulation vortex ! This is patch is hard-coded for test suite optimization used in the 2D_zero_circ_vortex case: This analytic patch uses ! geometry 2 if (patch_id == 2) then diff --git a/src/common/include/3dHardcodedIC.fpp b/src/common/include/3dHardcodedIC.fpp index f2d7e19ce2..e599303463 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -165,10 +165,10 @@ end if q_prim_vf(E_idx)%sf(i, j, k) = p_th*rcut*xcut + p_am - case (370) + case (370) ! 3D extrusion of 2D profile from external data ! This hardcoded case extrudes a 2D profile to initialize a 3D simulation domain @: HardcodedReadValues() - case (380) + case (380) ! Taylor-Green vortex ! This is patch is hard-coded for test suite optimization used in the 3D_TaylorGreenVortex case: This analytic patch used ! geometry 9 Mach = 0.1 diff --git a/src/common/include/ExtrusionHardcodedIC.fpp b/src/common/include/ExtrusionHardcodedIC.fpp index 0adb8beaa1..b5e8b379da 100644 --- a/src/common/include/ExtrusionHardcodedIC.fpp +++ b/src/common/include/ExtrusionHardcodedIC.fpp @@ -1,4 +1,4 @@ -!> @brief Allocate memory and read initial condition data for IC extrusion. +!> Allocate memory and read initial condition data for IC extrusion. !> !> @details !> This macro handles the complete initialization process for IC extrusion by: diff --git a/src/common/include/macros.fpp b/src/common/include/macros.fpp index 3f773b3240..61c13886c5 100644 --- a/src/common/include/macros.fpp +++ b/src/common/include/macros.fpp @@ -14,7 +14,7 @@ ! Caution: This macro requires the use of a binding script to set CUDA_VISIBLE_DEVICES, such that we have one GPU device per MPI ! rank. That's because for both cudaMemAdvise (preferred location) and cudaMemPrefetchAsync we use location = device_id = 0. For an -! example see misc/nvidia_uvm/bind.sh. +! example see misc/nvidia_uvm/bind.sh. NVIDIA unified memory page placement hint #:def PREFER_GPU(*args) #ifdef MFC_SIMULATION #ifdef __NVCOMPILER_GPU_UNIFIED_MEM @@ -55,6 +55,7 @@ #endif #:enddef +! Allocate and create GPU device memory #:def ALLOCATE(*args) @:LOG({'@:ALLOCATE(${re.sub(' +', ' ', ', '.join(args))}$)'}) #:set allocated_variables = ', '.join(args) @@ -74,6 +75,7 @@ $:GPU_ENTER_DATA(create='[' + joined + ']') #:enddef ALLOCATE +! Free GPU device memory and deallocate #:def DEALLOCATE(*args) @:LOG({'@:DEALLOCATE(${re.sub(' +', ' ', ', '.join(args))}$)'}) #:set allocated_variables = ', '.join(args) @@ -81,6 +83,7 @@ deallocate (${allocated_variables}$) #:enddef DEALLOCATE +! Cray-specific GPU pointer setup for vector fields #:def ACC_SETUP_VFs(*args) #ifdef _CRAYFTN block @@ -104,6 +107,7 @@ #endif #:enddef +! Cray-specific GPU pointer setup for scalar fields #:def ACC_SETUP_SFs(*args) #ifdef _CRAYFTN block @@ -119,6 +123,7 @@ #endif #:enddef +! Cray-specific GPU pointer setup for acoustic source spatials #:def ACC_SETUP_source_spatials(*args) #ifdef _CRAYFTN block diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 4c93feaeb7..33dd8dff2c 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -39,7 +39,7 @@ module m_boundary_common contains - !> @brief Allocates and sets up boundary condition buffer arrays for all coordinate directions. + !> Allocate and set up boundary condition buffer arrays for all coordinate directions. impure subroutine s_initialize_boundary_common_module() integer :: i, j @@ -70,8 +70,7 @@ contains end subroutine s_initialize_boundary_common_module - !> The purpose of this procedure is to populate the buffers of the primitive variables, depending on the selected boundary - !! conditions. + !> Populate the buffers of the primitive variables based on the selected boundary conditions. impure subroutine s_populate_variables_buffers(bc_type, q_prim_vf, pb_in, mv_in) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -272,7 +271,7 @@ contains end subroutine s_populate_variables_buffers - !> @brief Fills ghost cells by copying the nearest boundary cell value along the specified direction. + !> Fill ghost cells by copying the nearest boundary cell value along the specified direction. subroutine s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_ghost_cell_extrapolation', parallelism='[seq]', cray_inline=True) @@ -327,8 +326,7 @@ contains end subroutine s_ghost_cell_extrapolation - !> @brief Applies reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the normal velocity - !! component. + !> Apply reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the normal velocity component. subroutine s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') @@ -551,7 +549,7 @@ contains end subroutine s_symmetry - !> @brief Applies periodic boundary conditions by copying values from the opposite domain boundary. + !> Apply periodic boundary conditions by copying values from the opposite domain boundary. subroutine s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') @@ -673,8 +671,7 @@ contains end subroutine s_periodic - !> @brief Applies axis boundary conditions for cylindrical coordinates by reflecting values across the axis with azimuthal phase - !! shift. + !> Apply axis boundary conditions for cylindrical coordinates by reflecting values across the axis with azimuthal phase shift. subroutine s_axis(q_prim_vf, pb_in, mv_in, k, l) $:GPU_ROUTINE(parallelism='[seq]') @@ -724,7 +721,7 @@ contains end subroutine s_axis - !> @brief Applies slip wall boundary conditions by extrapolating scalars and reflecting the wall-normal velocity component. + !> Apply slip wall boundary conditions by extrapolating scalars and reflecting the wall-normal velocity component. subroutine s_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_slip_wall',parallelism='[seq]', cray_inline=True) @@ -803,7 +800,7 @@ contains end subroutine s_slip_wall - !> @brief Applies no-slip wall boundary conditions by reflecting and negating all velocity components at the wall. + !> Apply no-slip wall boundary conditions by reflecting and negating all velocity components at the wall. subroutine s_no_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_no_slip_wall',parallelism='[seq]', cray_inline=True) @@ -907,7 +904,7 @@ contains end subroutine s_no_slip_wall - !> @brief Applies Dirichlet boundary conditions by prescribing ghost cell values from stored boundary buffers. + !> Apply Dirichlet boundary conditions by prescribing ghost cell values from stored boundary buffers. subroutine s_dirichlet(q_prim_vf, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_dirichlet',parallelism='[seq]', cray_inline=True) @@ -970,7 +967,7 @@ contains end subroutine s_dirichlet - !> @brief Extrapolates QBMM bubble pressure and mass-vapor variables into ghost cells by copying boundary values. + !> Extrapolate QBMM bubble pressure and mass-vapor variables into ghost cells by copying boundary values. subroutine s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') @@ -1043,7 +1040,7 @@ contains end subroutine s_qbmm_extrapolation - !> @brief Populates ghost cell buffers for the color function and its divergence used in capillary surface tension. + !> Populate ghost cell buffers for the color function and its divergence used in capillary surface tension. impure subroutine s_populate_capillary_buffers(c_divs, bc_type) type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs @@ -1178,7 +1175,7 @@ contains end subroutine s_populate_capillary_buffers - !> @brief Applies periodic boundary conditions to the color function and its divergence fields. + !> Apply periodic boundary conditions to the color function and its divergence fields. subroutine s_color_function_periodic(c_divs, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_color_function_periodic', parallelism='[seq]', cray_inline=True) @@ -1233,7 +1230,7 @@ contains end subroutine s_color_function_periodic - !> @brief Applies reflective boundary conditions to the color function and its divergence fields. + !> Apply reflective boundary conditions to the color function and its divergence fields. subroutine s_color_function_reflective(c_divs, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_color_function_reflective', parallelism='[seq]', cray_inline=True) @@ -1312,7 +1309,7 @@ contains end subroutine s_color_function_reflective - !> @brief Extrapolates the color function and its divergence into ghost cells by copying boundary values. + !> Extrapolate the color function and its divergence into ghost cells by copying boundary values. subroutine s_color_function_ghost_cell_extrapolation(c_divs, bc_dir, bc_loc, k, l) $:GPU_ROUTINE(function_name='s_color_function_ghost_cell_extrapolation', parallelism='[seq]', cray_inline=True) @@ -1367,7 +1364,7 @@ contains end subroutine s_color_function_ghost_cell_extrapolation - !> @brief Populates ghost cell buffers for the Jacobian scalar field used in the IGR elliptic solver. + !> Populate ghost cell buffers for the Jacobian scalar field used in the IGR elliptic solver. impure subroutine s_populate_F_igr_buffers(bc_type, jac_sf) type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type @@ -1534,7 +1531,7 @@ contains end subroutine s_populate_F_igr_buffers - !> @brief Creates MPI derived datatypes for boundary condition type arrays and buffer arrays used in parallel I/O. + !> Create MPI derived datatypes for boundary condition type arrays and buffer arrays used in parallel I/O. impure subroutine s_create_mpi_types(bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type @@ -1569,7 +1566,7 @@ contains end subroutine s_create_mpi_types - !> @brief Writes boundary condition type and buffer data to serial (unformatted) restart files. + !> Write boundary condition type and buffer data to serial (unformatted) restart files. subroutine s_write_serial_boundary_condition_files(q_prim_vf, bc_type, step_dirpath, old_grid_in) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1608,7 +1605,7 @@ contains end subroutine s_write_serial_boundary_condition_files - !> @brief Writes boundary condition type and buffer data to per-rank parallel files using MPI I/O. + !> Write boundary condition type and buffer data to per-rank parallel files using MPI I/O. subroutine s_write_parallel_boundary_condition_files(q_prim_vf, bc_type) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1673,7 +1670,7 @@ contains end subroutine s_write_parallel_boundary_condition_files - !> @brief Reads boundary condition type and buffer data from serial (unformatted) restart files. + !> Read boundary condition type and buffer data from serial (unformatted) restart files. subroutine s_read_serial_boundary_condition_files(step_dirpath, bc_type) character(LEN=*), intent(in) :: step_dirpath @@ -1718,7 +1715,7 @@ contains end subroutine s_read_serial_boundary_condition_files - !> @brief Reads boundary condition type and buffer data from per-rank parallel files using MPI I/O. + !> Read boundary condition type and buffer data from per-rank parallel files using MPI I/O. subroutine s_read_parallel_boundary_condition_files(bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type @@ -1783,7 +1780,7 @@ contains end subroutine s_read_parallel_boundary_condition_files - !> @brief Packs primitive variable boundary slices into bc_buffers arrays for serialization. + !> Pack primitive variable boundary slices into bc_buffers arrays for serialization. subroutine s_pack_boundary_condition_buffers(q_prim_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1826,7 +1823,7 @@ contains end subroutine s_pack_boundary_condition_buffers - !> @brief Initializes the per-cell boundary condition type arrays with the global default BC values. + !> Initialize the per-cell boundary condition type arrays with the global default BC values. subroutine s_assign_default_bc_type(bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type @@ -1852,8 +1849,8 @@ contains end subroutine s_assign_default_bc_type - !> The purpose of this subroutine is to populate the buffers of the grid variables, which are constituted of the cell- boundary - !! locations and cell-width distributions, based on the boundary conditions. + !> Populate the buffers of the grid variables, which are constituted of the cell-boundary locations and cell-width + !! distributions, based on the boundary conditions. subroutine s_populate_grid_variables_buffers integer :: i @@ -2037,7 +2034,7 @@ contains end subroutine s_populate_grid_variables_buffers - !> @brief Deallocates boundary condition buffer arrays allocated during module initialization. + !> Deallocate boundary condition buffer arrays allocated during module initialization. subroutine s_finalize_boundary_common_module() if (bc_io) then diff --git a/src/common/m_checker_common.fpp b/src/common/m_checker_common.fpp index a828dfe596..df71030ec9 100644 --- a/src/common/m_checker_common.fpp +++ b/src/common/m_checker_common.fpp @@ -32,7 +32,7 @@ contains end subroutine s_check_inputs_common #ifndef MFC_SIMULATION - !> @brief Verifies that the total number of grid cells meets the minimum required by the number of dimensions and MPI ranks. + !> Verify that the total number of grid cells meets the minimum required by the number of dimensions and MPI ranks. impure subroutine s_check_total_cells character(len=18) :: numStr !< for int to string conversion @@ -48,7 +48,7 @@ contains end subroutine s_check_total_cells #endif - !> @brief Checks that simulation parameters stay within AMD GPU compiler limits when case optimization is disabled. + !> Check that simulation parameters stay within AMD GPU compiler limits when case optimization is disabled. impure subroutine s_check_amd #:if not MFC_CASE_OPTIMIZATION diff --git a/src/common/m_chemistry.fpp b/src/common/m_chemistry.fpp index 65734d6987..66f1e97923 100644 --- a/src/common/m_chemistry.fpp +++ b/src/common/m_chemistry.fpp @@ -31,7 +31,7 @@ module m_chemistry contains - !> @brief Computes mixture viscosities for left and right states and inverts them for use as reciprocal Reynolds numbers. + !> Compute mixture viscosities for left and right states and invert them for use as reciprocal Reynolds numbers. subroutine compute_viscosity_and_inversion(T_L, Ys_L, T_R, Ys_R, Re_L, Re_R) $:GPU_ROUTINE(function_name='compute_viscosity_and_inversion',parallelism='[seq]', cray_inline=True) @@ -47,7 +47,7 @@ contains end subroutine compute_viscosity_and_inversion - !> @brief Initializes the temperature field from conservative variables by inverting the energy equation. + !> Initialize the temperature field from conservative variables by inverting the energy equation. subroutine s_compute_q_T_sf(q_T_sf, q_cons_vf, bounds) ! Initialize the temperature field at the start of the simulation to reasonable values. Temperature is computed the regular @@ -82,7 +82,7 @@ contains end subroutine s_compute_q_T_sf - !> @brief Computes the temperature field from primitive variables using the ideal gas law and mixture molecular weight. + !> Compute the temperature field from primitive variables using the ideal gas law and mixture molecular weight. subroutine s_compute_T_from_primitives(q_T_sf, q_prim_vf, bounds) type(scalar_field), intent(inout) :: q_T_sf @@ -107,7 +107,7 @@ contains end subroutine s_compute_T_from_primitives - !> @brief Adds chemical reaction source terms to the species transport RHS using net production rates. + !> Add chemical reaction source terms to the species transport RHS using net production rates. subroutine s_compute_chemistry_reaction_flux(rhs_vf, q_cons_qp, q_T_sf, q_prim_qp, bounds) type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf @@ -157,7 +157,7 @@ contains end subroutine s_compute_chemistry_reaction_flux - !> @brief Computes species mass diffusion fluxes at cell interfaces using mixture-averaged diffusivities. + !> Compute species mass diffusion fluxes at cell interfaces using mixture-averaged diffusivities. subroutine s_compute_chemistry_diffusion_flux(idir, q_prim_qp, flux_src_vf, irx, iry, irz) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_qp diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index bba8d62f74..fda370dac8 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -26,7 +26,7 @@ impure subroutine s_create_directory(dir_name) end subroutine s_create_directory - !> @brief Deletes a file at the given path using a platform-specific system command. + !> Delete a file at the given path using a platform-specific system command. impure subroutine s_delete_file(filepath) character(LEN=*), intent(in) :: filepath @@ -39,7 +39,7 @@ impure subroutine s_delete_file(filepath) end subroutine s_delete_file - !> @brief Recursively deletes a directory using a platform-specific system command. + !> Recursively delete a directory using a platform-specific system command. impure subroutine s_delete_directory(dir_name) character(LEN=*), intent(in) :: dir_name @@ -53,7 +53,6 @@ impure subroutine s_delete_directory(dir_name) end subroutine s_delete_directory !> Inquires on the existence of a directory - !! @param fileloc File directory location !! @param dircheck Switch that indicates if directory exists impure subroutine my_inquire(fileloc, dircheck) @@ -68,7 +67,7 @@ impure subroutine my_inquire(fileloc, dircheck) end subroutine my_inquire - !> @brief Retrieves the current working directory path via the GETCWD intrinsic. + !> Retrieve the current working directory path via the GETCWD intrinsic. impure subroutine s_get_cwd(cwd) character(LEN=*), intent(out) :: cwd @@ -77,7 +76,7 @@ impure subroutine s_get_cwd(cwd) end subroutine s_get_cwd - !> @brief Extracts the base filename from a directory path using the system basename command. + !> Extract the base filename from a directory path using the system basename command. impure subroutine s_get_basename(dirpath, basename) character(LEN=*), intent(in) :: dirpath diff --git a/src/common/m_delay_file_access.f90 b/src/common/m_delay_file_access.f90 index 0c2f57bd8a..48f888ab06 100644 --- a/src/common/m_delay_file_access.f90 +++ b/src/common/m_delay_file_access.f90 @@ -15,7 +15,7 @@ module m_delay_file_access contains - !> @brief Introduces a rank-dependent busy-wait delay to stagger parallel file access and reduce I/O contention. + !> Introduce a rank-dependent busy-wait delay to stagger parallel file access and reduce I/O contention. impure subroutine DelayFileAccess(ProcessRank) integer, intent(in) :: ProcessRank diff --git a/src/common/m_finite_differences.fpp b/src/common/m_finite_differences.fpp index 9724f3ecdd..98758c2a0e 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -69,14 +69,9 @@ contains end subroutine s_compute_fd_divergence - !> The purpose of this subroutine is to compute the finite- difference coefficients for the centered schemes utilized in - !! computations of first order spatial derivatives in the s-coordinate direction. The s-coordinate direction refers to the x-, - !! y- or z-coordinate direction, depending on the subroutine's inputs. Note that coefficients of up to 4th order accuracy are - !! available. - !! @param q Number of cells in the s-coordinate direction - !! @param s_cc Locations of the cell-centers in the s-coordinate direction + !> Compute the centered finite-difference coefficients for first-order spatial derivatives in the s-coordinate direction (x, y, + !! or z). Supports up to 4th order accuracy. !! @param fd_coeff_s Finite-diff. coefficients in the s-coordinate direction - !! @param local_buff_size Size of the local buffer !! @param fd_number_in Finite-difference number !! @param fd_order_in Finite-difference order of accuracy !! @param offset_s Optional offset bounds in the s-coordinate direction diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index f0eb1b0dcb..b519ffb856 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -22,10 +22,6 @@ module m_helper contains !> Computes the bubble number density n from the primitive variables - !! @param vftmp is the void fraction - !! @param Rtmp is the bubble radii - !! @param ntmp is the output number bubble density - !! @param weights is the quadrature weights subroutine s_comp_n_from_prim(vftmp, Rtmp, ntmp, weights) $:GPU_ROUTINE(parallelism='[seq]') @@ -40,7 +36,7 @@ contains end subroutine s_comp_n_from_prim - !> @brief Computes the bubble number density from the conservative void fraction and weighted bubble radii. + !> Compute the bubble number density from the conservative void fraction and weighted bubble radii. subroutine s_comp_n_from_cons(vftmp, nRtmp, ntmp, weights) $:GPU_ROUTINE(parallelism='[seq]') @@ -55,7 +51,7 @@ contains end subroutine s_comp_n_from_cons - !> @brief Prints a 2D real array to standard output, optionally dividing each element by a given scalar. + !> Print a 2D real array to standard output, optionally dividing each element by a given scalar. impure subroutine s_print_2D_array(A, div) real(wp), dimension(:,:), intent(in) :: A @@ -85,7 +81,7 @@ contains end subroutine s_print_2D_array - !> bubbles_euler + polytropic bubbles_euler + non-polytropic bubbles_lagrange + non-polytropic + !> Initialize bubble model arrays for Euler or Lagrangian bubbles with polytropic or non-polytropic gas. impure subroutine s_initialize_bubbles_model() ! Allocate memory @@ -115,7 +111,7 @@ contains end subroutine s_initialize_bubbles_model - !> + !> Set bubble physical parameters and nondimensional numbers from the input configuration. impure subroutine s_initialize_bubble_vars() R0ref = bub_pp%R0ref; p0ref = bub_pp%p0ref @@ -217,10 +213,6 @@ contains end subroutine s_initialize_nonpoly !> Computes the transfer coefficient for the non-polytropic bubble compression process - !! @param omega natural frequencies - !! @param peclet Peclet number - !! @param Re_trans Real part of the transport coefficients - !! @param Im_trans Imaginary part of the transport coefficients elemental subroutine s_transcoeff(omega, peclet, Re_trans, Im_trans) real(wp), intent(in) :: omega, peclet @@ -239,7 +231,7 @@ contains end subroutine s_transcoeff - !> @brief Converts an integer to its trimmed string representation. + !> Convert an integer to its trimmed string representation. elemental subroutine s_int_to_str(i, res) integer, intent(in) :: i @@ -290,10 +282,7 @@ contains end subroutine s_simpson - !> This procedure computes the cross product of two vectors. - !! @param a First vector. - !! @param b Second vector. - !! @return The cross product of the two vectors. + !> Compute the cross product of two vectors. pure function f_cross(a, b) result(c) $:GPU_ROUTINE(parallelism='[seq]') @@ -307,9 +296,7 @@ contains end function f_cross - !> This procedure swaps two real numbers. - !! @param lhs Left-hand side. - !! @param rhs Right-hand side. + !> Swap two real numbers. elemental subroutine s_swap(lhs, rhs) real(wp), intent(inout) :: lhs, rhs @@ -321,10 +308,7 @@ contains end subroutine s_swap - !> This procedure creates a transformation matrix. - !! @param param Parameters for the transformation. - !! @param center Optional center point for the transformation. - !! @return Transformation matrix. + !> Create a transformation matrix. function f_create_transform_matrix(param, center) result(out_matrix) type(ic_model_parameters), intent(in) :: param @@ -362,9 +346,7 @@ contains end function f_create_transform_matrix - !> This procedure transforms a vector by a matrix. - !! @param vec Vector to transform. - !! @param matrix Transformation matrix. + !> Transform a vector by a matrix. subroutine s_transform_vec(vec, matrix) real(wp), dimension(1:3), intent(inout) :: vec @@ -376,10 +358,7 @@ contains end subroutine s_transform_vec - !> This procedure transforms a triangle by a matrix, one vertex at a time. - !! @param triangle Triangle to transform. - !! @param matrix Transformation matrix. - !! @param matrix_n Normal transformation matrix. + !> Transform a triangle by a matrix, one vertex at a time. subroutine s_transform_triangle(triangle, matrix, matrix_n) type(t_triangle), intent(inout) :: triangle @@ -394,10 +373,7 @@ contains end subroutine s_transform_triangle - !> This procedure transforms a model by a matrix, one triangle at a time. - !! @param model Model to transform. - !! @param matrix Transformation matrix. - !! @param matrix_n Normal transformation matrix. + !> Transform a model by a matrix, one triangle at a time. subroutine s_transform_model(model, matrix, matrix_n) type(t_model), intent(inout) :: model @@ -410,9 +386,7 @@ contains end subroutine s_transform_model - !> This procedure creates a bounding box for a model. - !! @param model Model to create bounding box for. - !! @return Bounding box. + !> Create a bounding box for a model. function f_create_bbox(model) result(bbox) type(t_model), intent(in) :: model @@ -437,10 +411,7 @@ contains end function f_create_bbox - !> This procedure performs xor on lhs and rhs. - !! @param lhs logical input. - !! @param rhs other logical input. - !! @return xored result. + !> Perform XOR on lhs and rhs. elemental function f_xor(lhs, rhs) result(res) logical, intent(in) :: lhs, rhs @@ -450,9 +421,7 @@ contains end function f_xor - !> This procedure converts logical to 1 or 0. - !! @param predicate A Logical argument. - !! @return 1 if .true., 0 if .false.. + !> Convert a logical to 1 or 0. elemental function f_logical_to_int(predicate) result(int) logical, intent(in) :: predicate @@ -498,7 +467,6 @@ contains !! @param x argument (typically cos(theta)), should be in [-1,1] !! @param l degree (>= 0) !! @param m_order order (0 <= m_order <= l) - !! @return result_P P_l^m(x) recursive function associated_legendre(x, l, m_order) result(result_P) integer, intent(in) :: l, m_order @@ -533,9 +501,7 @@ contains end function associated_legendre - !> This function calculates the double factorial value of an integer - !! @param n_in is the input integer - !! @return R is the double factorial value of n + !> Calculate the double factorial of an integer elemental function double_factorial(n_in) result(R_result) integer, intent(in) :: n_in @@ -547,9 +513,7 @@ contains end function double_factorial - !> The following function calculates the factorial value of an integer - !! @param n_in is the input integer - !! @return R is the factorial value of n + !> Calculate the factorial of an integer elemental function factorial(n_in) result(R_result) integer, intent(in) :: n_in @@ -561,11 +525,8 @@ contains end function factorial - !> This function calculates a smooth cut-on function that is zero for x values smaller than zero and goes to one. It can be used - !! for generating smooth initial conditions - !! @param x is the input value - !! @param eps is the smoothing parameter - !! @return fx is the cut-on function evaluated at x + !> Calculate a smooth cut-on function that is zero for x values smaller than zero and goes to one, for generating smooth initial + !! conditions function f_cut_on(x, eps) result(fx) real(wp), intent(in) :: x, eps @@ -575,11 +536,8 @@ contains end function f_cut_on - !> This function calculates a smooth cut-off function that is one for x values smaller than zero and goes to zero. It can be - !! used for generating smooth initial conditions - !! @param x is the input value - !! @param eps is the smoothing parameter - !! @return fx is the cut-ff function evaluated at x + !> Calculate a smooth cut-off function that is one for x values smaller than zero and goes to zero, for generating smooth + !! initial conditions function f_cut_off(x, eps) result(fx) real(wp), intent(in) :: x, eps @@ -589,9 +547,7 @@ contains end function f_cut_off - !> This function is a helper function for the functions f_cut_on and f_cut_off - !! @param x is the input value - !! @return gx is the result + !> Helper function for f_cut_on and f_cut_off function f_gx(x) result(gx) real(wp), intent(in) :: x @@ -605,7 +561,7 @@ contains end function f_gx - !> @brief Downsamples conservative variable fields by a factor of 3 in each direction using volume averaging. + !> Downsample conservative variable fields by a factor of 3 in each direction using volume averaging. subroutine s_downsample_data(q_cons_vf, q_cons_temp, m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_cons_temp @@ -647,7 +603,7 @@ contains end subroutine s_downsample_data - !> @brief Upsamples conservative variable fields from a coarsened grid back to the original resolution using interpolation. + !> Upsample conservative variable fields from a coarsened grid back to the original resolution using interpolation. subroutine s_upsample_data(q_cons_vf, q_cons_temp) type(scalar_field), intent(inout), dimension(sys_size) :: q_cons_vf, q_cons_temp diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index e0055275e1..17caabb99f 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -16,11 +16,8 @@ module m_helper_basic contains - !> This procedure checks if two floating point numbers of wp are within tolerance. - !! @param a First number. - !! @param b Second number. + !> Check if two floating point numbers of wp are within tolerance. !! @param tol_input Relative error (default = 1.e-10_wp). - !! @return Result of the comparison. logical elemental function f_approx_equal(a, b, tol_input) result(res) $:GPU_ROUTINE(parallelism='[seq]') @@ -44,11 +41,8 @@ contains end function f_approx_equal - !> This procedure checks if the point numbers of wp belongs to another array are within tolerance. - !! @param a First number. - !! @param b Array that contains several point numbers. + !> Check if a wp value approximately matches any element of an array within tolerance. !! @param tol_input Relative error (default = 1e-10_wp). - !! @return Result of the comparison. logical function f_approx_in_array(a, b, tol_input) result(res) $:GPU_ROUTINE(parallelism='[seq]') @@ -76,7 +70,6 @@ contains end function f_approx_in_array !> Checks if a real(wp) variable is of default value. - !! @param var Variable to check. logical elemental function f_is_default(var) result(res) $:GPU_ROUTINE(parallelism='[seq]') @@ -87,7 +80,6 @@ contains end function f_is_default !> Checks if ALL elements of a real(wp) array are of default value. - !! @param var_array Array to check. logical function f_all_default(var_array) result(res) real(wp), intent(in) :: var_array(:) @@ -97,7 +89,6 @@ contains end function f_all_default !> Checks if a real(wp) variable is an integer. - !! @param var Variable to check. logical elemental function f_is_integer(var) result(res) $:GPU_ROUTINE(parallelism='[seq]') @@ -157,10 +148,7 @@ contains end subroutine s_configure_coordinate_bounds !> Updates the min and max number of cells in each set of axes - !! @param bounds Min ans max values to update - !! @param m Number of cells in x-axis - !! @param n Number of cells in y-axis - !! @param p Number of cells in z-axis + !! @param bounds Min and max values to update elemental subroutine s_update_cell_bounds(bounds, m, n, p) type(cell_num_bounds), intent(out) :: bounds diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index 785b075f26..528c58af77 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -42,9 +42,7 @@ module m_model contains - !> This procedure reads a binary STL file. - !! @param filepath Path to the STL file. - !! @param model The binary of the STL file. + !> Read a binary STL file. impure subroutine s_read_stl_binary(filepath, model) character(LEN=*), intent(in) :: filepath @@ -88,9 +86,7 @@ contains end subroutine s_read_stl_binary - !> This procedure reads an ASCII STL file. - !! @param filepath Path to the STL file. - !! @param model the STL file. + !> Read an ASCII STL file. impure subroutine s_read_stl_ascii(filepath, model) character(LEN=*), intent(in) :: filepath @@ -198,9 +194,7 @@ contains end subroutine s_read_stl_ascii - !> This procedure reads an STL file. - !! @param filepath Path to the STL file. - !! @param model the STL file. + !> Read an STL file. impure subroutine s_read_stl(filepath, model) character(LEN=*), intent(in) :: filepath @@ -228,9 +222,7 @@ contains end subroutine s_read_stl - !> This procedure reads an OBJ file. - !! @param filepath Path to the obj file. - !! @param model The obj file. + !> Read an OBJ file. impure subroutine s_read_obj(filepath, model) character(LEN=*), intent(in) :: filepath @@ -299,9 +291,7 @@ contains end subroutine s_read_obj - !> This procedure reads a mesh from a file. - !! @param filepath Path to the file to read. - !! @return The model read from the file. + !> Read a mesh from a file. impure function f_model_read(filepath) result(model) character(LEN=*), intent(in) :: filepath @@ -320,9 +310,7 @@ contains end function f_model_read - !> This procedure writes a binary STL file. - !! @param filepath Path to the STL file. - !! @param model STL to write + !> Write a binary STL file. impure subroutine s_write_stl(filepath, model) character(LEN=*), intent(in) :: filepath @@ -367,9 +355,7 @@ contains end subroutine s_write_stl - !> This procedure writes an OBJ file. - !! @param filepath Path to the obj file. - !! @param model obj to write. + !> Write an OBJ file. impure subroutine s_write_obj(filepath, model) character(LEN=*), intent(in) :: filepath @@ -400,9 +386,7 @@ contains end subroutine s_write_obj - !> This procedure writes a binary STL file. - !! @param filepath Path to the file to write. - !! @param model Model to write. + !> Write a mesh to a file. impure subroutine s_model_write(filepath, model) character(LEN=*), intent(in) :: filepath @@ -421,7 +405,7 @@ contains end subroutine s_model_write - !> This procedure frees the memory allocated for an STL mesh. + !> Free the memory allocated for an STL mesh. subroutine s_model_free(model) type(t_model), intent(inout) :: model @@ -458,7 +442,7 @@ contains end function f_read_line - !> @brief Reads the next non-comment line from a model file, using a buffered look-ahead mechanism. + !> Read the next non-comment line from a model file, using a buffered look-ahead mechanism. impure subroutine s_skip_ignored_lines(iunit, buffered_line, is_buffered) integer, intent(in) :: iunit @@ -478,8 +462,8 @@ contains end subroutine s_skip_ignored_lines - !> This function is used to replace the fortran random number generator because the native generator is not compatible being - !! called from GPU routines/functions + !> Generate a pseudo-random number using a seed-based xorshift, replacing the Fortran intrinsic which is incompatible with GPU + !! routines function f_model_random_number(seed) result(rval) ! $:GPU_ROUTINE(parallelism='[seq]') @@ -495,12 +479,8 @@ contains end function f_model_random_number - !> This procedure, recursively, finds whether a point is inside an octree. - !! @param model Model to search in. - !! @param point Point to test. - !! @param spacing Space around the point to search in (grid spacing). + !> Determine whether a point is inside a model using stochastic ray casting. !! @param spc Number of samples per cell. - !! @return True if the point is inside the octree, false otherwise. impure function f_model_is_inside(model, point, spacing, spc) result(fraction) ! $:GPU_ROUTINE(parallelism='[seq]') @@ -552,13 +532,10 @@ contains end function f_model_is_inside - !> This procedure determines if a point is inside a surface using the generalized winding number (Jacobson et al., SIGGRAPH - !! 2013). In 3D, sums the solid angle subtended by each triangle (Van Oosterom-Strackee formula). In 2D (p==0), sums the signed - !! angle subtended by each boundary edge. Returns ~1.0 inside, ~0.0 outside. Unlike ray casting, this is robust to small - !! triangles/edges and vertex winding order. - !! @param ntrs Number of triangles in the model. - !! @param pid Patch ID of this model. - !! @param point Point to test. + !> Determine if a point is inside a surface using the generalized winding number (Jacobson et al., SIGGRAPH 2013). In 3D, sums + !! the solid angle subtended by each triangle (Van Oosterom-Strackee formula). In 2D (p==0), sums the signed angle subtended by + !! each boundary edge. Returns ~1.0 inside, ~0.0 outside. Unlike ray casting, this is robust to small triangles/edges and vertex + !! winding order. !! @return fraction Winding number (~1.0 inside, ~0.0 outside). function f_model_is_inside_flat(ntrs, pid, point) result(fraction) @@ -620,11 +597,9 @@ contains end function f_model_is_inside_flat - !> This procedure checks if a ray intersects a triangle using the Moller-Trumbore algorithm (barycentric coordinates). Unlike - !! the previous cross-product sign test, this is vertex winding-order independent. - !! @param ray Ray. - !! @param triangle Triangle. - !! @return 1 if the ray intersects the triangle, 0 otherwise. + !> Check if a ray intersects a triangle using the Moller-Trumbore algorithm (barycentric coordinates). Unlike the previous + !! cross-product sign test, this is vertex winding-order independent. + !! @return 1 if the ray intersects the triangle, 0 otherwise. function f_intersects_triangle(ray, triangle) result(intersects) $:GPU_ROUTINE(parallelism='[seq]') @@ -662,9 +637,7 @@ contains end function f_intersects_triangle - !> This procedure checks and labels edges shared by two or more triangles facets of the 2D STL model. - !! @param model Model to search in. - !! @param boundary_vertex_count Output total boundary vertex count + !> Check and label edges shared by two or more triangle facets of the 2D STL model. subroutine s_check_boundary(model, boundary_v, boundary_vertex_count, boundary_edge_count) type(t_model), intent(in) :: model @@ -776,7 +749,7 @@ contains end subroutine s_check_boundary - !> This procedure appends the edge end vertices to a temporary buffer. + !> Append the edge end vertices to a temporary buffer. subroutine s_register_edge(temp_boundary_v, edge, edge_index, edge_count) integer, intent(inout) :: edge_index !< Edge index iterator @@ -791,15 +764,8 @@ contains end subroutine s_register_edge - !> This procedure determines the levelset distance and normals of 3D models by computing the exact closest point via projection - !! onto triangle surfaces. - !! @param ntrs Number of triangles for this patch - !! @param trs_v Flat GPU array of triangle vertices for all patches - !! @param trs_n Flat GPU array of triangle normals for all patches - !! @param pid Patch index into the arrays - !! @param point The cell center of the current levelset cell - !! @param normals Output levelset normals - !! @param distance Output levelset distance + !> Determine the levelset distance and normals of 3D models by computing the exact closest point via projection onto triangle + !! surfaces. subroutine s_distance_normals_3D(ntrs, pid, point, normals, distance) $:GPU_ROUTINE(parallelism='[seq]') @@ -928,14 +894,8 @@ contains end subroutine s_distance_normals_3D - !> This procedure determines the levelset distance and normals of 2D models by computing the exact closest point via projection - !! onto boundary edges. - !! @param boundary_v Flat GPU array of boundary vertices/normals for all patches - !! @param pid Patch index into the boundary_v array - !! @param boundary_edge_count Total number of boundary edges for this patch - !! @param point The cell center of the current levelset cell - !! @param normals Output levelset normals - !! @param distance Output levelset distance + !> Determine the levelset distance and normals of 2D models by computing the exact closest point via projection onto boundary + !! edges. subroutine s_distance_normals_2D(pid, boundary_edge_count, point, normals, distance) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index b91410f313..7fdd087cbc 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -39,8 +39,7 @@ module m_mpi_common contains - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the module. impure subroutine s_initialize_mpi_common_module #ifdef MFC_MPI @@ -77,8 +76,7 @@ contains end subroutine s_initialize_mpi_common_module - !> The subroutine initializes the MPI execution environment and queries both the number of processors which will be available - !! for the job and the local processor rank. + !> Initialize the MPI execution environment and query the number of processors and local rank. impure subroutine s_mpi_initialize #ifdef MFC_MPI @@ -101,9 +99,6 @@ contains end subroutine s_mpi_initialize - !! @param q_cons_vf Conservative variables - !! @param ib_markers track if a cell is within the immersed boundary - !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_initialize_mpi_data(q_cons_vf, ib_markers, beta) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -185,7 +180,6 @@ contains end subroutine s_initialize_mpi_data - !! @param q_cons_vf Conservative variables subroutine s_initialize_mpi_data_ds(q_cons_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -231,7 +225,7 @@ contains end subroutine s_initialize_mpi_data_ds - !> @brief Gathers variable-length real vectors from all MPI ranks onto the root process. + !> Gather variable-length real vectors from all MPI ranks onto the root process. impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root) integer, intent(in) :: counts ! Array of vector lengths for each process @@ -261,7 +255,7 @@ contains end subroutine s_mpi_gather_data - !> @brief Gathers per-rank time step wall-clock times onto rank 0 for performance reporting. + !> Gather per-rank time step wall-clock times onto rank 0 for performance reporting. impure subroutine mpi_bcast_time_step_values(proc_time, time_avg) real(wp), dimension(0:num_procs - 1), intent(inout) :: proc_time @@ -275,7 +269,7 @@ contains end subroutine mpi_bcast_time_step_values - !> @brief Prints a case file error with the prohibited condition and message, then aborts execution. + !> Print a case file error with the prohibited condition and message, then abort execution. impure subroutine s_prohibit_abort(condition, message) character(len=*), intent(in) :: condition, message @@ -295,12 +289,6 @@ contains !! performed by sifting through the local extrema of each stability criterion. Note that each of the local extrema is from a !! single process, within its assigned section of the computational domain. Finally, note that the global extrema values are !! only bookkeept on the rank 0 processor. - !! @param icfl_max_loc Local maximum ICFL stability criterion - !! @param vcfl_max_loc Local maximum VCFL stability criterion - !! @param Rc_min_loc Local minimum Rc stability criterion - !! @param icfl_max_glb Global maximum ICFL stability criterion - !! @param vcfl_max_glb Global maximum VCFL stability criterion - !! @param Rc_min_glb Global minimum Rc stability criterion impure subroutine s_mpi_reduce_stability_criteria_extrema(icfl_max_loc, vcfl_max_loc, Rc_min_loc, icfl_max_glb, vcfl_max_glb, & & Rc_min_glb) @@ -334,11 +322,7 @@ contains end subroutine s_mpi_reduce_stability_criteria_extrema - !> The following subroutine takes the input local variable from all processors and reduces to the sum of all values. The reduced - !! variable is recorded back onto the original local variable on each processor. - ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the - ! communicator. - !! @param var_glb The globally reduced value + !> Reduce a local real value to its global sum across all MPI ranks. impure subroutine s_mpi_allreduce_sum(var_loc, var_glb) real(wp), intent(in) :: var_loc @@ -352,8 +336,7 @@ contains end subroutine s_mpi_allreduce_sum - !> This subroutine follows the behavior of the s_mpi_allreduce_sum subroutine - !> with the additional feature that it reduces an array of vectors. + !> Reduce an array of vectors to their global sums across all MPI ranks. impure subroutine s_mpi_allreduce_vectors_sum(var_loc, var_glb, num_vectors, vector_length) integer, intent(in) :: num_vectors, vector_length @@ -374,11 +357,7 @@ contains end subroutine s_mpi_allreduce_vectors_sum - !> The following subroutine takes the input local variable from all processors and reduces to the sum of all values. The reduced - !! variable is recorded back onto the original local variable on each processor. - ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the - ! communicator. - !! @param var_glb The globally reduced value + !> Reduce a local integer value to its global sum across all MPI ranks. impure subroutine s_mpi_allreduce_integer_sum(var_loc, var_glb) integer, intent(in) :: var_loc @@ -394,11 +373,7 @@ contains end subroutine s_mpi_allreduce_integer_sum - !> The following subroutine takes the input local variable from all processors and reduces to the minimum of all values. The - !! reduced variable is recorded back onto the original local variable on each processor. - ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the - ! communicator. - !! @param var_glb The globally reduced value + !> Reduce a local real value to its global minimum across all MPI ranks. impure subroutine s_mpi_allreduce_min(var_loc, var_glb) real(wp), intent(in) :: var_loc @@ -412,11 +387,7 @@ contains end subroutine s_mpi_allreduce_min - !> The following subroutine takes the input local variable from all processors and reduces to the maximum of all values. The - !! reduced variable is recorded back onto the original local variable on each processor. - ! ! @param var_loc Some variable containing the local value which should be reduced amongst all the processors in the - ! communicator. - !! @param var_glb The globally reduced value + !> Reduce a local real value to its global maximum across all MPI ranks. impure subroutine s_mpi_allreduce_max(var_loc, var_glb) real(wp), intent(in) :: var_loc @@ -430,8 +401,7 @@ contains end subroutine s_mpi_allreduce_max - !> The following subroutine takes the inputted variable and determines its minimum value on the entire computational domain. The - !! result is stored back into inputted variable. + !> Reduce a local real value to its global minimum and broadcast the result to all ranks. ! ! @param var_loc holds the local value to be reduced among all the processors in communicator. On output, the variable holds ! the minimum value, reduced amongst all of the local values. impure subroutine s_mpi_reduce_min(var_loc) @@ -451,9 +421,7 @@ contains end subroutine s_mpi_reduce_min - !> The following subroutine takes the first element of the 2-element inputted variable and determines its maximum value on the - !! entire computational domain. The result is stored back into the first element of the variable while the rank of the processor - !! that is in charge of the sub- domain containing the maximum is stored into the second element of the variable. + !> Reduce a 2-element variable to its global maximum value with the owning processor rank (MPI_MAXLOC). ! ! @param var_loc On input, this variable holds the local value and processor rank, which are to be reduced among all the ! processors in communicator. On output, this variable holds the maximum value, reduced amongst all of the local values, and the ! process rank to which the value belongs. @@ -476,8 +444,6 @@ contains end subroutine s_mpi_reduce_maxloc !> The subroutine terminates the MPI execution environment. - !! @param prnt error message to be printed - !! @param code optional exit code impure subroutine s_mpi_abort(prnt, code) character(len=*), intent(in), optional :: prnt @@ -532,12 +498,6 @@ contains !> The goal of this procedure is to populate the buffers of the cell-average conservative variables by communicating with the !! neighboring processors. - !! @param q_comm Cell-average conservative variables - !! @param mpi_dir MPI communication coordinate direction - !! @param pbc_loc Processor boundary condition (PBC) location - !! @param nVar Number of variables to communicate - !! @param pb_in Optional internal bubble pressure - !! @param mv_in Optional bubble mass velocity subroutine s_mpi_sendrecv_variables_buffers(q_comm, mpi_dir, pbc_loc, nVar, pb_in, mv_in) type(scalar_field), dimension(1:), intent(inout) :: q_comm @@ -952,9 +912,7 @@ contains end subroutine s_mpi_sendrecv_variables_buffers - !> The purpose of this procedure is to optimally decompose the computational domain among the available processors. This is - !! performed by attempting to award each processor, in each of the coordinate directions, approximately the same number of - !! cells, and then recomputing the affected global parameters. + !> Decompose the computational domain among processors by balancing cells per rank in each coordinate direction. subroutine s_mpi_decompose_computational_domain #ifdef MFC_MPI @@ -1371,8 +1329,6 @@ contains !> The goal of this procedure is to populate the buffers of the grid variables by communicating with the neighboring processors. !! Note that only the buffers of the cell-width distributions are handled in such a way. This is because the buffers of !! cell-boundary locations may be calculated directly from those of the cell-width distributions. - !! @param mpi_dir MPI communication coordinate direction - !! @param pbc_loc Processor boundary condition (PBC) location #ifndef MFC_PRE_PROCESS subroutine s_mpi_sendrecv_grid_variables_buffers(mpi_dir, pbc_loc) diff --git a/src/common/m_nvtx.f90 b/src/common/m_nvtx.f90 index ebd7791977..4708c8b78e 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -57,7 +57,7 @@ end subroutine nvtxRangePop contains - !> @brief Pushes a named NVTX range for GPU profiling, optionally with a color based on the given identifier. + !> Push a named NVTX range for GPU profiling, optionally with a color based on the given identifier. subroutine nvtxStartRange(name, id) character(kind=c_char, len=*), intent(in) :: name @@ -78,7 +78,7 @@ subroutine nvtxStartRange(name, id) end subroutine nvtxStartRange - !> @brief Pops the current NVTX range to end the GPU profiling region. + !> Pop the current NVTX range to end the GPU profiling region. subroutine nvtxEndRange #if defined(MFC_GPU) && defined(__PGI) diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index dbb5a9af19..6114aa2d0e 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -39,8 +39,7 @@ module m_phase_change contains - !> This subroutine should dispatch to the correct relaxation solver based some parameter. It replaces the procedure pointer, - !! which CCE is breaking on. + !> Dispatch to the correct relaxation solver. Replaces the procedure pointer, which CCE is breaking on. impure subroutine s_relaxation_solver(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -50,8 +49,7 @@ contains end subroutine s_relaxation_solver - !> The purpose of this subroutine is to initialize the phase change module by setting the parameters needed for phase change and - !! selecting the phase change module that will be used (pT- or pTg-equilibrium) + !> Initialize the phase change module by setting saturation curve coefficients for pT- or pTg-equilibrium impure subroutine s_initialize_phasechange_module ! Saturation curve coefficients via stiffened gas EOS. Saurel et al. JCP (2008), Le Metayer et al. JFE (2004) @@ -65,9 +63,7 @@ contains end subroutine s_initialize_phasechange_module - !> This subroutine is created to activate either the pT- (N fluids) or the pTg-equilibrium (2 fluids for g-equilibrium) model, - !! also considering mass depletion, depending on the incoming state conditions. - !! @param q_cons_vf Cell-average conservative variables + !> Apply pT- or pTg-equilibrium relaxation with mass depletion based on the incoming state conditions. subroutine s_infinite_relaxation_k(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -254,16 +250,8 @@ contains end subroutine s_infinite_relaxation_k - !> This auxiliary subroutine is created to activate the pT-equilibrium for N fluids - !! @param j generic loop iterator for x direction - !! @param k generic loop iterator for y direction - !! @param l generic loop iterator for z direction - !! @param MFL flag that tells whether the fluid is gas (0), liquid (1), or a mixture (2) - !! @param pS equilibrium pressure at the interface - !! @param p_infpT stiffness for the participating fluids under pT-equilibrium - !! @param q_cons_vf Cell-average conservative variables - !! @param rhoe mixture energy - !! @param TS equilibrium temperature at the interface + !> Apply pT-equilibrium relaxation for N fluids + !! @param MFL flag: 0=gas, 1=liquid, 2=mixture subroutine s_infinite_pt_relaxation_k(j, k, l, MFL, pS, p_infpT, q_cons_vf, rhoe, TS) $:GPU_ROUTINE(function_name='s_infinite_pt_relaxation_k', parallelism='[seq]', cray_noinline=True) @@ -356,16 +344,8 @@ contains end subroutine s_infinite_pt_relaxation_k - !> This auxiliary subroutine is created to activate the pTg-equilibrium for N fluids under pT and 2 fluids under - !! pTg-equilibrium. There is a final common p and T during relaxation - !! @param j generic loop iterator for x direction - !! @param k generic loop iterator for y direction - !! @param l generic loop iterator for z direction - !! @param pS equilibrium pressure at the interface - !! @param p_infpT stiffness for the participating fluids under pT-equilibrium - !! @param rhoe mixture energy - !! @param q_cons_vf Cell-average conservative variables - !! @param TS equilibrium temperature at the interface + !> Apply pTg-equilibrium relaxation for N fluids under pT and 2 fluids under pTg-equilibrium. There is a final common p and T + !! during relaxation subroutine s_infinite_ptg_relaxation_k(j, k, l, pS, p_infpT, rhoe, q_cons_vf, TS) $:GPU_ROUTINE(function_name='s_infinite_ptg_relaxation_k', parallelism='[seq]', cray_noinline=True) @@ -535,14 +515,8 @@ contains end subroutine s_infinite_ptg_relaxation_k - !> This auxiliary subroutine corrects the partial densities of the REACTING fluids in case one of them is negative but their sum - !! is positive. Inert phases are not corrected at this moment - !! @param MCT partial density correction parameter - !! @param q_cons_vf Cell-average conservative variables - !! @param rM sum of the reacting masses - !! @param j generic loop iterator for x direction - !! @param k generic loop iterator for y direction - !! @param l generic loop iterator for z direction + !> Correct the partial densities of the reacting fluids in case one of them is negative but their sum is positive. Inert phases + !! are not corrected at this moment subroutine s_correct_partial_densities(MCT, q_cons_vf, rM, j, k, l) $:GPU_ROUTINE(function_name='s_correct_partial_densities', parallelism='[seq]', cray_noinline=True) @@ -581,10 +555,7 @@ contains end subroutine s_correct_partial_densities - !> This auxiliary subroutine finds the Saturation temperature for a given saturation pressure through a newton solver - !! @param pSat Saturation Pressure - !! @param TSat Saturation Temperature - !! @param TSIn equilibrium Temperature + !> Find the saturation temperature for a given saturation pressure using a Newton solver elemental subroutine s_TSat(pSat, TSat, TSIn) $:GPU_ROUTINE(function_name='s_TSat',parallelism='[seq]', cray_noinline=True) @@ -635,7 +606,7 @@ contains end subroutine s_TSat - !> This subroutine finalizes the phase change module + !> Finalize the phase change module impure subroutine s_finalize_relaxation_solver_module end subroutine s_finalize_relaxation_solver_module diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 50753735af..21dacbc8cd 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -60,17 +60,6 @@ contains !> Dispatch to the s_convert_mixture_to_mixture_variables and s_convert_species_to_mixture_variables subroutines. Replaces a !! procedure pointer. - !! @param q_vf Conservative or primitive variables - !! @param i First-coordinate cell index - !! @param j Second-coordinate cell index - !! @param k Third-coordinate cell index - !! @param rho Density - !! @param gamma Specific heat ratio function - !! @param pi_inf Liquid stiffness function - !! @param qv Fluid reference energy - !! @param Re_K Reynolds number (optional) - !! @param G_K Shear modulus (optional) - !! @param G Shear moduli of the fluids (optional) subroutine s_convert_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv, Re_K, G_K, G) type(scalar_field), dimension(sys_size), intent(in) :: q_vf @@ -88,21 +77,7 @@ contains end subroutine s_convert_to_mixture_variables - !> This procedure conditionally calculates the appropriate pressure - !! @param energy Energy - !! @param alf Void Fraction - !! @param dyn_p Dynamic Pressure - !! @param pi_inf Liquid Stiffness - !! @param gamma Specific Heat Ratio - !! @param rho Density - !! @param qv fluid reference energy - !! @param rhoYks Species partial densities - !! @param pres Pressure to calculate - !! @param T Temperature - !! @param stress Shear Stress - !! @param mom Momentum - !! @param G Shear modulus (optional) - !! @param pres_mag Magnetic pressure (optional) + !> Compute the pressure from the appropriate equation of state subroutine s_compute_pressure(energy, alf, dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, stress, mom, G, pres_mag) $:GPU_ROUTINE(function_name='s_compute_pressure',parallelism='[seq]', cray_noinline=True) @@ -169,16 +144,9 @@ contains end subroutine s_compute_pressure - !> This subroutine is designed for the gamma/pi_inf model and provided a set of either conservative or primitive variables, - !! transfers the density, specific heat ratio function and the liquid stiffness function from q_vf to rho, gamma and pi_inf. - !! @param q_vf conservative or primitive variables - !! @param i cell index to transfer mixture variables - !! @param j cell index to transfer mixture variables - !! @param k cell index to transfer mixture variables - !! @param rho density - !! @param gamma specific heat ratio function - !! @param pi_inf liquid stiffness - !! @param qv fluid reference energy + !> Convert mixture variables to density, gamma, pi_inf, and qv for the gamma/pi_inf model. Given conservative or primitive + !! variables, transfers the density, specific heat ratio function and the liquid stiffness function from q_vf to rho, gamma and + !! pi_inf. subroutine s_convert_mixture_to_mixture_variables(q_vf, i, j, k, rho, gamma, pi_inf, qv) type(scalar_field), dimension(sys_size), intent(in) :: q_vf @@ -205,20 +173,9 @@ contains end subroutine s_convert_mixture_to_mixture_variables - !> This subroutine is designed for the volume fraction model and provided a set of either conservative or primitive variables, - !! computes the density, the specific heat ratio function and the liquid stiffness function from q_vf and stores the results - !! into rho, gamma and pi_inf. - !! @param q_vf primitive variables - !! @param k Cell index - !! @param l Cell index - !! @param r Cell index - !! @param rho density - !! @param gamma specific heat ratio - !! @param pi_inf liquid stiffness - !! @param qv fluid reference energy - !! @param Re_K Reynolds number (optional) - !! @param G_K Shear modulus (optional) - !! @param G Shear moduli of the fluids (optional) + !> Convert species volume fractions and partial densities to mixture density, gamma, pi_inf, and qv. Given conservative or + !! primitive variables, computes the density, the specific heat ratio function and the liquid stiffness function from q_vf and + !! stores the results into rho, gamma and pi_inf. subroutine s_convert_species_to_mixture_variables(q_vf, k, l, r, rho, gamma, pi_inf, qv, Re_K, G_K, G) type(scalar_field), dimension(sys_size), intent(in) :: q_vf @@ -286,8 +243,7 @@ contains end subroutine s_convert_species_to_mixture_variables - !> @brief GPU-accelerated conversion of species volume fractions and partial densities to mixture density, gamma, pi_inf, and - !! qv. + !> GPU-accelerated conversion of species volume fractions and partial densities to mixture density, gamma, pi_inf, and qv. subroutine s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K, G_K, G) $:GPU_ROUTINE(function_name='s_convert_species_to_mixture_variables_acc', parallelism='[seq]', cray_noinline=True) @@ -356,8 +312,7 @@ contains end subroutine s_convert_species_to_mixture_variables_acc - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the variables conversion module. impure subroutine s_initialize_variables_conversion_module integer :: i, j @@ -437,7 +392,7 @@ contains end subroutine s_initialize_variables_conversion_module - !> @brief Initializes bubble mass-vapor values at quadrature nodes from the conserved moment statistics. + !> Initialize bubble mass-vapor values at quadrature nodes from the conserved moment statistics. subroutine s_initialize_mv(qK_cons_vf, mv) type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf @@ -466,7 +421,7 @@ contains end subroutine s_initialize_mv - !> @brief Initializes bubble internal pressures at quadrature nodes using isothermal relations from the Preston model. + !> Initialize bubble internal pressures at quadrature nodes using isothermal relations from the Preston model. subroutine s_initialize_pb(qK_cons_vf, mv, pb) type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf @@ -503,10 +458,6 @@ contains !> Convert conserved variables (rho*alpha, rho*u, E, alpha) to primitives (rho, u, p, alpha). Conversion depends on model_eqns: !! each model has different variable sets and EOS. - !! @param qK_cons_vf Conservative variables - !! @param q_T_sf Temperature scalar field - !! @param qK_prim_vf Primitive variables - !! @param ibounds Index bounds in each coordinate direction subroutine s_convert_conservative_to_primitive_variables(qK_cons_vf, q_T_sf, qK_prim_vf, ibounds) type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf @@ -819,8 +770,6 @@ contains end subroutine s_convert_conservative_to_primitive_variables !> Convert primitives (rho, u, p, alpha) to conserved variables (rho*alpha, rho*u, E, alpha). - !! @param q_prim_vf Primitive variables - !! @param q_cons_vf Conservative variables impure subroutine s_convert_primitive_to_conservative_variables(q_prim_vf, q_cons_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1064,15 +1013,7 @@ contains end subroutine s_convert_primitive_to_conservative_variables - !> The following subroutine handles the conversion between the primitive variables and the Eulerian flux variables. - !! @param qK_prim_vf Primitive variables - !! @param FK_vf Flux variables - !! @param FK_src_vf Flux source variables - !! @param is1 Index bounds in the first coordinate direction - !! @param is2 Index bounds in the second coordinate direction - !! @param is3 Index bounds in the third coordinate direction - !! @param s2b Starting boundary index in the second coordinate direction - !! @param s3b Starting boundary index in the third coordinate direction + !> Convert primitive variables to Eulerian flux variables. subroutine s_convert_primitive_to_flux_variables(qK_prim_vf, FK_vf, FK_src_vf, is1, is2, is3, s2b, s3b) integer, intent(in) :: s2b, s3b @@ -1216,7 +1157,7 @@ contains end subroutine s_convert_primitive_to_flux_variables - !> This subroutine computes partial densities and volume fractions + !> Compute partial densities and volume fractions subroutine s_compute_species_fraction(q_vf, k, l, r, alpha_rho_K, alpha_K) $:GPU_ROUTINE(function_name='s_compute_species_fraction', parallelism='[seq]', cray_noinline=True) @@ -1267,7 +1208,7 @@ contains end subroutine s_compute_species_fraction - !> @brief Deallocates fluid property arrays and post-processing fields allocated during module initialization. + !> Deallocate fluid property arrays and post-processing fields allocated during module initialization. impure subroutine s_finalize_variables_conversion_module() ! Deallocating the density, the specific heat ratio function and the liquid stiffness function @@ -1290,7 +1231,7 @@ contains end subroutine s_finalize_variables_conversion_module #ifndef MFC_PRE_PROCESS - !> @brief Computes the speed of sound from thermodynamic state variables, supporting multiple equation-of-state models. + !> Compute the speed of sound from thermodynamic state variables, supporting multiple equation-of-state models. subroutine s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, vel_sum, c_c, c, qv) $:GPU_ROUTINE(parallelism='[seq]') @@ -1352,7 +1293,7 @@ contains #endif #ifndef MFC_PRE_PROCESS - !> @brief Computes the fast magnetosonic wave speed from the sound speed, density, and magnetic field components. + !> Compute the fast magnetosonic wave speed from the sound speed, density, and magnetic field components. subroutine s_compute_fast_magnetosonic_speed(rho, c, B, norm, c_fast, h) $:GPU_ROUTINE(function_name='s_compute_fast_magnetosonic_speed', parallelism='[seq]', cray_noinline=True) diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index 9b1f61175e..612e84e4be 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -25,7 +25,6 @@ module m_data_input abstract interface !> Subroutine for reading data files - !! @param t_step Current time-step to input impure subroutine s_read_abstract_data_files(t_step) implicit none @@ -48,12 +47,6 @@ end subroutine s_read_abstract_data_files contains !> Helper subroutine to read grid data files for a given direction - !! @param t_step_dir Directory containing the time-step data - !! @param direction Direction name ('x', 'y', 'z') - !! @param cb_array Cell boundary array to populate - !! @param d_array Cell width array to populate - !! @param cc_array Cell center array to populate - !! @param size_dim Size of the dimension impure subroutine s_read_grid_data_direction(t_step_dir, direction, cb_array, d_array, cc_array, size_dim) character(len=*), intent(in) :: t_step_dir @@ -83,9 +76,6 @@ end subroutine s_read_grid_data_direction #ifdef MFC_MPI !> Helper subroutine to setup MPI data I/O parameters - !! @param data_size Local array size (output) - !! @param m_MOK, n_MOK, p_MOK MPI offset kinds for dimensions (output) - !! @param WP_MOK, MOK, str_MOK, NVARS_MOK Other MPI offset kinds (output) impure subroutine s_setup_mpi_io_params(data_size, m_MOK, n_MOK, p_MOK, WP_MOK, MOK, str_MOK, NVARS_MOK) integer, intent(out) :: data_size @@ -112,8 +102,6 @@ end subroutine s_setup_mpi_io_params #endif !> Helper subroutine to read IB data files - !! @param file_loc_base Base file location for IB data - !! @param t_step Time step index impure subroutine s_read_ib_data_files(file_loc_base, t_step) character(len=*), intent(in) :: file_loc_base @@ -174,10 +162,6 @@ impure subroutine s_read_ib_data_files(file_loc_base, t_step) end subroutine s_read_ib_data_files !> Helper subroutine to allocate field arrays for given dimensionality - !! @param local_start_idx Starting index for allocation - !! @param end_x End index for x dimension - !! @param end_y End index for y dimension - !! @param end_z End index for z dimension impure subroutine s_allocate_field_arrays(local_start_idx, end_x, end_y, end_z) integer, intent(in) :: local_start_idx, end_x, end_y, end_z @@ -198,9 +182,8 @@ impure subroutine s_allocate_field_arrays(local_start_idx, end_x, end_y, end_z) end subroutine s_allocate_field_arrays - !> This subroutine is called at each time-step that has to be post-processed in order to read the raw data files present in the - !! corresponding time-step directory and to populate the associated grid and conservative variables. - !! @param t_step Current time-step + !> Read the raw data files present in the corresponding time-step directory and to populate the associated grid and conservative + !! variables. impure subroutine s_read_serial_data_files(t_step) integer, intent(in) :: t_step @@ -259,9 +242,8 @@ impure subroutine s_read_serial_data_files(t_step) end subroutine s_read_serial_data_files - !> This subroutine is called at each time-step that has to be post-processed in order to parallel-read the raw data files - !! present in the corresponding time-step directory and to populate the associated grid and conservative variables. - !! @param t_step Current time-step + !> Parallel-read the raw data files present in the corresponding time-step directory and to populate the associated grid and + !! conservative variables. impure subroutine s_read_parallel_data_files(t_step) integer, intent(in) :: t_step @@ -380,9 +362,6 @@ end subroutine s_read_parallel_data_files #ifdef MFC_MPI !> Helper subroutine to read parallel conservative variable data - !! @param t_step Current time-step - !! @param m_MOK, n_MOK, p_MOK MPI offset kinds for dimensions - !! @param WP_MOK, MOK, str_MOK, NVARS_MOK Other MPI offset kinds impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, WP_MOK, MOK, str_MOK, NVARS_MOK) integer, intent(in) :: t_step diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 918d2eda9b..f3db054290 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -74,7 +74,7 @@ module m_data_output contains - !> @brief Allocate storage arrays, configure output directories, and count flow variables for formatted database output. + !> Allocate storage arrays, configure output directories, and count flow variables for formatted database output. impure subroutine s_initialize_data_output_module() character(LEN=len_trim(case_dir) + 2*name_len) :: file_loc @@ -314,7 +314,7 @@ contains end subroutine s_initialize_data_output_module - !> @brief Compute the cell-index bounds for the user-specified partial output domain in each coordinate direction. + !> Compute the cell-index bounds for the user-specified partial output domain in each coordinate direction. impure subroutine s_define_output_region integer :: i @@ -349,7 +349,7 @@ contains end subroutine s_define_output_region - !> @brief Open (or create) the Silo-HDF5 or Binary formatted database slave and master files for a given time step. + !> Open (or create) the Silo-HDF5 or Binary formatted database slave and master files for a given time step. impure subroutine s_open_formatted_database_file(t_step) integer, intent(in) :: t_step @@ -414,7 +414,7 @@ contains end subroutine s_open_formatted_database_file - !> @brief Open the interface data file for appending extracted interface coordinates. + !> Open the interface data file for appending extracted interface coordinates. impure subroutine s_open_intf_data_file() character(LEN=path_len + 3*name_len) :: file_path @@ -426,7 +426,7 @@ contains end subroutine s_open_intf_data_file - !> @brief Open the energy data file for appending volume-integrated energy budget quantities. + !> Open the energy data file for appending volume-integrated energy budget quantities. impure subroutine s_open_energy_data_file() character(LEN=path_len + 3*name_len) :: file_path @@ -438,7 +438,7 @@ contains end subroutine s_open_energy_data_file - !> @brief Write the computational grid (cell-boundary coordinates) to the formatted database slave and master files. + !> Write the computational grid (cell-boundary coordinates) to the formatted database slave and master files. impure subroutine s_write_grid_to_formatted_database_file(t_step) integer, intent(in) :: t_step @@ -575,7 +575,7 @@ contains end subroutine s_write_grid_to_formatted_database_file - !> @brief Write a single flow variable field to the formatted database slave and master files for a given time step. + !> Write a single flow variable field to the formatted database slave and master files for a given time step. impure subroutine s_write_variable_to_formatted_database_file(varname, t_step) character(LEN=*), intent(in) :: varname @@ -708,8 +708,7 @@ contains end subroutine s_write_variable_to_formatted_database_file - !> Subroutine that writes the post processed results in the folder 'lag_bubbles_data' - !! @param t_step Current time step + !> Write the post-processed results in the folder 'lag_bubbles_data' impure subroutine s_write_lag_bubbles_results_to_text(t_step) integer, intent(in) :: t_step @@ -862,7 +861,7 @@ contains end subroutine s_write_lag_bubbles_results_to_text - !> @brief Read Lagrangian bubble restart data and write bubble positions and scalar fields to the Silo database. + !> Read Lagrangian bubble restart data and write bubble positions and scalar fields to the Silo database. impure subroutine s_write_lag_bubbles_to_formatted_database_file(t_step) integer, intent(in) :: t_step @@ -1070,7 +1069,7 @@ contains end subroutine s_write_lag_bubbles_to_formatted_database_file - !> @brief Write a single Lagrangian bubble point-variable to the Silo database slave and master files. + !> Write a single Lagrangian bubble point-variable to the Silo database slave and master files. subroutine s_write_lag_variable_to_formatted_database_file(varname, t_step, data, nBubs) character(len=*), intent(in) :: varname @@ -1165,8 +1164,7 @@ contains end subroutine s_write_ib_state_files - !> @brief Extract the volume-fraction interface contour from primitive fields and write the coordinates to the interface data - !! file. + !> Extract the volume-fraction interface contour from primitive fields and write the coordinates to the interface data file. impure subroutine s_write_intf_data_file(q_prim_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1252,8 +1250,7 @@ contains end subroutine s_write_intf_data_file - !> @brief Compute volume-integrated kinetic, potential, and internal energies and write the energy budget to the energy data - !! file. + !> Compute volume-integrated kinetic, potential, and internal energies and write the energy budget to the energy data file. impure subroutine s_write_energy_data_file(q_prim_vf, q_cons_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf, q_cons_vf @@ -1345,7 +1342,7 @@ contains end subroutine s_write_energy_data_file - !> @brief Close the formatted database slave file and, for the root process, the master file. + !> Close the formatted database slave file and, for the root process, the master file. impure subroutine s_close_formatted_database_file() integer :: ierr @@ -1360,21 +1357,21 @@ contains end subroutine s_close_formatted_database_file - !> @brief Close the interface data file. + !> Close the interface data file. impure subroutine s_close_intf_data_file() close (211) end subroutine s_close_intf_data_file - !> @brief Close the energy data file. + !> Close the energy data file. impure subroutine s_close_energy_data_file() close (251) end subroutine s_close_energy_data_file - !> @brief Deallocate module arrays and release all data-output resources. + !> Deallocate module arrays and release all data-output resources. impure subroutine s_finalize_data_output_module() deallocate (q_sf) diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 24a292df28..ddf7c61f9e 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -69,9 +69,8 @@ contains end subroutine s_initialize_derived_variables_module - !> This subroutine receives as input the specific heat ratio function, gamma_sf, and derives from it the specific heat ratio. - !! The latter is stored in the derived flow quantity storage variable, q_sf. - !! @param q_sf Specific heat ratio + !> Derive the specific heat ratio from the specific heat ratio function gamma_sf. The latter is stored in the derived flow + !! quantity storage variable, q_sf. subroutine s_derive_specific_heat_ratio(q_sf) real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & @@ -88,10 +87,9 @@ contains end subroutine s_derive_specific_heat_ratio - !> This subroutine admits as inputs the specific heat ratio function and the liquid stiffness function, gamma_sf and pi_inf_sf, + !> Compute the liquid stiffness from the specific heat ratio function gamma_sf and the liquid stiffness function pi_inf_sf, !! respectively. These are used to calculate the values of the liquid stiffness, which are stored in the derived flow quantity !! storage variable, q_sf. - !! @param q_sf Liquid stiffness subroutine s_derive_liquid_stiffness(q_sf) real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & @@ -108,11 +106,9 @@ contains end subroutine s_derive_liquid_stiffness - !> This subroutine admits as inputs the primitive variables, the density, the specific heat ratio function and liquid stiffness + !> Compute the speed of sound from the primitive variables, density, specific heat ratio function, and liquid stiffness !! function. It then computes from those variables the values of the speed of sound, which are stored in the derived flow !! quantity storage variable, q_sf. - !! @param q_prim_vf Primitive variables - !! @param q_sf Speed of sound subroutine s_derive_sound_speed(q_prim_vf, q_sf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -147,12 +143,8 @@ contains end subroutine s_derive_sound_speed - !> This subroutine derives the flux_limiter at cell boundary i+1/2. This is an approximation because the velocity used to - !! determine the upwind direction is the velocity at the cell center i instead of the contact velocity at the cell boundary from - !! the Riemann solver. - !! @param i Component indicator - !! @param q_prim_vf Primitive variables - !! @param q_sf Flux limiter + !> Derive the flux limiter at cell boundary i+1/2. This is an approximation because the velocity used to determine the upwind + !! direction is the velocity at the cell center i instead of the contact velocity at the cell boundary from the Riemann solver. subroutine s_derive_flux_limiter(i, q_prim_vf, q_sf) integer, intent(in) :: i @@ -223,10 +215,6 @@ contains end subroutine s_derive_flux_limiter !> Solve Ax=b via Gaussian elimination with partial pivoting - !! @param A Input matrix - !! @param b right-hand-side - !! @param sol Solution - !! @param ndim Problem size subroutine s_solve_linear_system(A, b, sol, ndim) integer, intent(in) :: ndim @@ -262,12 +250,8 @@ contains end subroutine s_solve_linear_system - !> This subroutine receives as inputs the indicator of the component of the vorticity that should be outputted and the primitive - !! variables. From those inputs, it proceeds to calculate values of the desired vorticity component, which are subsequently - !! stored in derived flow quantity storage variable, q_sf. - !! @param i Vorticity component indicator - !! @param q_prim_vf Primitive variables - !! @param q_sf Vorticity component + !> Compute the specified component of the vorticity from the primitive variables. From those inputs, it proceeds to calculate + !! values of the desired vorticity component, which are subsequently stored in derived flow quantity storage variable, q_sf. subroutine s_derive_vorticity_component(i, q_prim_vf, q_sf) integer, intent(in) :: i @@ -331,10 +315,8 @@ contains end subroutine s_derive_vorticity_component - !> This subroutine gets as inputs the primitive variables. From those inputs, it proceeds to calculate the value of the Q_M - !! function, which are subsequently stored in the derived flow quantity storage variable, q_sf. - !! @param q_prim_vf Primitive variables - !! @param q_sf Q_M + !> Compute the Q_M criterion from the primitive variables. The Q_M function, which are subsequently stored in the derived flow + !! quantity storage variable, q_sf. subroutine s_derive_qm(q_prim_vf, q_sf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -392,9 +374,7 @@ contains end subroutine s_derive_qm - !> This subroutine gets as inputs the primitive variables. From those inputs, it proceeds to calculate the Liutex vector and its - !! magnitude based on Xu et al. (2019). - !! @param q_prim_vf Primitive variables + !> Compute the Liutex vector and its magnitude based on Xu et al. (2019). impure subroutine s_derive_liutex(q_prim_vf, liutex_mag, liutex_axis) ! Liutex vortex identification via real eigenvector of velocity gradient, Xu et al. PoF (2019) @@ -498,10 +478,8 @@ contains end subroutine s_derive_liutex - !> This subroutine gets as inputs the conservative variables and density. From those inputs, it proceeds to calculate the values - !! of the numerical Schlieren function, which are subsequently stored in the derived flow quantity storage variable, q_sf. - !! @param q_cons_vf Conservative variables - !! @param q_sf Numerical Schlieren function + !> Compute the values of the numerical Schlieren function, which are subsequently stored in the derived flow quantity storage + !! variable, q_sf. impure subroutine s_derive_numerical_schlieren_function(q_cons_vf, q_sf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index 3139fac772..c462eca096 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -138,8 +138,7 @@ contains end subroutine s_mpi_bcast_user_inputs - !> This subroutine gathers the Silo database metadata for the spatial extents in order to boost the performance of the - !! multidimensional visualization. + !> Gather the Silo database metadata for the spatial extents to boost the performance of the multidimensional visualization. ! ! @param spatial_extents Spatial extents for each processor's sub-domain. First dimension corresponds to the minimum and ! maximum values, respectively, while the second dimension corresponds to the processor rank. impure subroutine s_mpi_gather_spatial_extents(spatial_extents) @@ -232,8 +231,8 @@ contains end subroutine s_mpi_gather_spatial_extents - !> This subroutine collects the sub-domain cell-boundary or cell-center locations data from all of the processors and puts back - !! together the grid of the entire computational domain on the rank 0 processor. This is only done for 1D simulations. + !> Collect the sub-domain cell-boundary or cell-center location data from all processors and put back together the grid of the + !! entire computational domain on the rank 0 processor. This is only done for 1D simulations. impure subroutine s_mpi_defragment_1d_grid_variable #ifdef MFC_MPI @@ -253,11 +252,8 @@ contains end subroutine s_mpi_defragment_1d_grid_variable - !> This subroutine gathers the Silo database metadata for the flow variable's extents as to boost performance of the - !! multidimensional visualization. - !! @param q_sf Flow variable defined on a single computational sub-domain - ! ! @param data_extents The flow variable extents on each of the processor's sub-domain. First dimension of array corresponds to - ! the former's minimum and maximum values, respectively, while second dimension corresponds to each processor's rank. + !> Gather the Silo database metadata for the flow variable's extents to boost performance of the multidimensional visualization. + !! @param q_sf Flow variable on a single computational sub-domain impure subroutine s_mpi_gather_data_extents(q_sf, data_extents) real(wp), dimension(:,:,:), intent(in) :: q_sf @@ -289,10 +285,10 @@ contains end subroutine s_mpi_gather_data_extents - !> This subroutine gathers the sub-domain flow variable data from all of the processors and puts it back together for the entire - !! computational domain on the rank 0 processor. This is only done for 1D simulations. - !! @param q_sf Flow variable defined on a single computational sub-domain - !! @param q_root_sf Flow variable defined on the entire computational domain + !> Gather the sub-domain flow variable data from all processors and reassemble it for the entire computational domain on the + !! rank 0 processor. This is only done for 1D simulations. + !! @param q_sf Flow variable on a single computational sub-domain + !! @param q_root_sf Flow variable on the entire computational domain impure subroutine s_mpi_defragment_1d_flow_variable(q_sf, q_root_sf) real(wp), dimension(0:m), intent(in) :: q_sf diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index af32db4459..038fd26867 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -135,7 +135,7 @@ contains end subroutine s_check_input_file - !> @brief Load grid and conservative data for a time step, fill ghost-cell buffers, and convert to primitive variables. + !> Load grid and conservative data for a time step, fill ghost-cell buffers, and convert to primitive variables. impure subroutine s_perform_time_step(t_step) integer, intent(inout) :: t_step @@ -165,7 +165,7 @@ contains end subroutine s_perform_time_step - !> @brief Derive requested flow quantities from primitive variables and write them to the formatted database files. + !> Derive requested flow quantities from primitive variables and write them to the formatted database files. impure subroutine s_save_data(t_step, varname, pres, c, H) integer, intent(inout) :: t_step @@ -745,7 +745,7 @@ contains end subroutine s_save_data - !> @brief Transpose 3-D complex data from x-pencil to y-pencil layout via MPI_Alltoall. + !> Transpose 3-D complex data from x-pencil to y-pencil layout via MPI_Alltoall. subroutine s_mpi_transpose_x2y complex(c_double_complex), allocatable :: sendbuf(:), recvbuf(:) @@ -787,7 +787,7 @@ contains end subroutine s_mpi_transpose_x2y - !> @brief Transpose 3-D complex data from y-pencil to z-pencil layout via MPI_Alltoall. + !> Transpose 3-D complex data from y-pencil to z-pencil layout via MPI_Alltoall. subroutine s_mpi_transpose_y2z complex(c_double_complex), allocatable :: sendbuf(:), recvbuf(:) @@ -830,7 +830,7 @@ contains end subroutine s_mpi_transpose_y2z - !> @brief Initialize all post-process sub-modules, set up I/O pointers, and prepare FFTW plans and MPI communicators. + !> Initialize all post-process sub-modules, set up I/O pointers, and prepare FFTW plans and MPI communicators. impure subroutine s_initialize_modules integer :: size_n(1), inembed(1), onembed(1) @@ -919,7 +919,7 @@ contains end subroutine s_initialize_modules - !> @brief Perform a distributed forward 3-D FFT using pencil decomposition with FFTW and MPI transposes. + !> Perform a distributed forward 3-D FFT using pencil decomposition with FFTW and MPI transposes. subroutine s_mpi_FFT_fwd integer :: j, k, l @@ -986,7 +986,7 @@ contains end subroutine s_mpi_FFT_fwd - !> @brief Set up the MPI environment, read and broadcast user inputs, and decompose the computational domain. + !> Set up the MPI environment, read and broadcast user inputs, and decompose the computational domain. impure subroutine s_initialize_mpi_domain num_dims = 1 + min(1, n) + min(1, p) @@ -1008,7 +1008,7 @@ contains end subroutine s_initialize_mpi_domain - !> @brief Destroy FFTW plans, free MPI communicators, and finalize all post-process sub-modules. + !> Destroy FFTW plans, free MPI communicators, and finalize all post-process sub-modules. impure subroutine s_finalize_modules s_read_data_files => null() diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index 915c1f6d8d..25f5939318 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -2,10 +2,10 @@ !! @file !! @brief Contains program p_main -!> @brief The post-process restructures raw unformatted data, outputted by the simulation, into a formatted database, Silo-HDF5 or -!! Binary, chosen by the user. The user may also specify which variables to include in the database. The choices range from any one -!! of the primitive and conservative variables, as well as quantities that can be derived from those such as the unadvected volume -!! fraction, specific heat ratio, liquid stiffness, speed of sound, vorticity and the numerical Schlieren function. +!> @brief Restructure raw simulation data into a formatted database (Silo-HDF5 or Binary, chosen by the user. The user may also +!! specify which variables to include in the database. The choices range from any one of the primitive and conservative variables, +!! as well as quantities that can be derived from those such as the unadvected volume fraction, specific heat ratio, liquid +!! stiffness, speed of sound, vorticity and the numerical Schlieren function. program p_main use m_global_parameters diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index be7e5ad00d..e47c05da1d 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -28,13 +28,6 @@ module m_assign_variables abstract interface !> Skeleton of s_assign_patch_mixture_primitive_variables and s_assign_patch_species_primitive_variables - !! @param patch_id is the patch identifier - !! @param j (x) cell index in which the mixture or species primitive variables from the indicated patch are assigned - !! @param k (y,th) cell index in which the mixture or species primitive variables from the indicated patch are assigned - !! @param l (z) cell index in which the mixture or species primitive variables from the indicated patch are assigned - !! @param eta pseudo volume fraction - !! @param q_prim_vf Primitive variables - !! @param patch_id_fp Array to track patch ids subroutine s_assign_patch_xxxxx_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) import :: scalar_field, sys_size, n, m, p, wp @@ -59,7 +52,7 @@ module m_assign_variables contains - !> @brief Allocates volume fraction sum and sets the patch primitive variable assignment procedure pointer. + !> Allocate volume fraction sum and set the patch primitive variable assignment procedure pointer. impure subroutine s_initialize_assign_variables_module if (.not. igr) then @@ -76,18 +69,11 @@ contains end subroutine s_initialize_assign_variables_module - !> This subroutine assigns the mixture primitive variables of the patch designated by the patch_id, to the cell that is - !! designated by the indexes (j,k,l). In addition, the variable bookkeeping the patch identities in the entire domain is updated - !! with the new assignment. Note that if the smoothing of the patch's boundaries is employed, the ensuing primitive variables in - !! the cell will be a type of combination of the current patch's primitive variables with those of the smoothing patch. The - !! specific details of the combination may be found in Shyue's work (1998). - !! @param patch_id the patch identifier - !! @param j the x-dir node index - !! @param k the y-dir node index - !! @param l the z-dir node index - !! @param eta pseudo volume fraction - !! @param q_prim_vf Primitive variables - !! @param patch_id_fp Array to track patch ids + !> Assign the mixture primitive variables of the patch designated by the patch_id to the cell that is designated by the indexes + !! (j,k,l). In addition, the variable bookkeeping the patch identities in the entire domain is updated with the new assignment. + !! Note that if the smoothing of the patch's boundaries is employed, the ensuing primitive variables in the cell will be a type + !! of combination of the current patch's primitive variables with those of the smoothing patch. The specific details of the + !! combination may be found in Shyue's work (1998). subroutine s_assign_patch_mixture_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) $:GPU_ROUTINE(parallelism='[seq]') @@ -148,11 +134,7 @@ contains end subroutine s_assign_patch_mixture_primitive_variables - !> @brief Applies a stable pressure perturbation following Ando's method for bubble-laden flows. - !! @param j the x-dir node index - !! @param k the y-dir node index - !! @param l the z-dir node index - !! @param q_prim_vf Primitive variables + !> Apply a stable pressure perturbation following Ando's method for bubble-laden flows. subroutine s_perturb_primitive(j, k, l, q_prim_vf) integer, intent(in) :: j, k, l @@ -223,15 +205,8 @@ contains end subroutine s_perturb_primitive - !> This subroutine assigns the species primitive variables. This follows s_assign_patch_species_primitive_variables with - !! adaptation for ensemble-averaged bubble modeling - !! @param patch_id the patch identifier - !! @param j the x-dir node index - !! @param k the y-dir node index - !! @param l the z-dir node index - !! @param eta pseudo volume fraction - !! @param q_prim_vf Primitive variables - !! @param patch_id_fp Array to track patch ids + !> Assign the species primitive variables, following s_assign_patch_species_primitive_variables with adaptation for + !! ensemble-averaged bubble modeling impure subroutine s_assign_patch_species_primitive_variables(patch_id, j, k, l, eta, q_prim_vf, patch_id_fp) $:GPU_ROUTINE(parallelism='[seq]') @@ -573,7 +548,7 @@ contains end subroutine s_assign_patch_species_primitive_variables - !> @brief Nullifies the patch primitive variable assignment procedure pointer. + !> Nullify the patch primitive variable assignment procedure pointer. impure subroutine s_finalize_assign_variables_module s_assign_patch_primitive_variables => null() diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index f7e52695aa..3e14ac06c3 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -23,7 +23,7 @@ module m_boundary_conditions private; public :: s_apply_boundary_patches contains - !> @brief Applies a line-segment boundary condition patch along a domain edge in 2D. + !> Apply a line-segment boundary condition patch along a domain edge in 2D. impure subroutine s_line_segment_bc(patch_id, bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type @@ -73,7 +73,7 @@ contains end subroutine s_line_segment_bc - !> @brief Applies a circular boundary condition patch on a domain face in 3D. + !> Apply a circular boundary condition patch on a domain face in 3D. impure subroutine s_circle_bc(patch_id, bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type @@ -133,7 +133,7 @@ contains end subroutine s_circle_bc - !> @brief Applies a rectangular boundary condition patch on a domain face in 3D. + !> Apply a rectangular boundary condition patch on a domain face in 3D. impure subroutine s_rectangle_bc(patch_id, bc_type) type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type @@ -217,7 +217,7 @@ contains end subroutine s_rectangle_bc - !> @brief Iterates over all boundary condition patches and dispatches them by geometry type. + !> Iterate over all boundary condition patches and dispatch them by geometry type. impure subroutine s_apply_boundary_patches(q_prim_vf, bc_type) type(scalar_field), dimension(sys_size) :: q_prim_vf diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index efcfe7891a..16a74020f9 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -29,7 +29,7 @@ module m_check_ib_patches contains - !> @brief Validates the geometry parameters of all active and inactive immersed boundary patches. + !> Validate the geometry parameters of all active and inactive immersed boundary patches. impure subroutine s_check_ib_patches integer :: i @@ -72,8 +72,8 @@ contains end subroutine s_check_ib_patches - !> This subroutine verifies that the geometric parameters of the circle patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the circle patch have been consistently inputted. + impure subroutine s_check_circle_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -85,8 +85,8 @@ contains end subroutine s_check_circle_ib_patch_geometry - !> This subroutine verifies that the geometric parameters of the ellipse patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the ellipse patch have been consistently inputted. + impure subroutine s_check_ellipse_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -99,8 +99,8 @@ contains end subroutine s_check_ellipse_ib_patch_geometry - !> This subroutine verifies that the geometric parameters of the airfoil patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the airfoil patch have been consistently inputted. + impure subroutine s_check_airfoil_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -113,8 +113,8 @@ contains end subroutine s_check_airfoil_ib_patch_geometry - !> This subroutine verifies that the geometric parameters of the 3d airfoil patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the 3D airfoil patch have been consistently inputted. + impure subroutine s_check_3d_airfoil_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -129,8 +129,8 @@ contains end subroutine s_check_3d_airfoil_ib_patch_geometry - !> This subroutine verifies that the geometric parameters of the rectangle patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the rectangle patch have been consistently inputted. + impure subroutine s_check_rectangle_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -143,8 +143,8 @@ contains end subroutine s_check_rectangle_ib_patch_geometry - !> This subroutine verifies that the geometric parameters of the sphere patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the sphere patch have been consistently inputted. + impure subroutine s_check_sphere_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -157,8 +157,8 @@ contains end subroutine s_check_sphere_ib_patch_geometry - !> This subroutine verifies that the geometric parameters of the cuboid patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the cuboid patch have been consistently inputted. + impure subroutine s_check_cuboid_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -172,8 +172,8 @@ contains end subroutine s_check_cuboid_ib_patch_geometry - !> This subroutine verifies that the geometric parameters of the cylinder patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the cylinder patch have been consistently inputted. + impure subroutine s_check_cylinder_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -194,8 +194,8 @@ contains end subroutine s_check_cylinder_ib_patch_geometry - !> This subroutine verifies that the geometric parameters of the model patch have consistently been inputted by the user. - !! @param patch_id Patch identifier + !> Verify that the geometric parameters of the model patch have been consistently inputted. + impure subroutine s_check_model_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index 908f6458f9..e9b41f761f 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -31,7 +31,7 @@ module m_check_patches contains - !> @brief Validates the geometry parameters of all active and inactive initial condition patches. + !> Validate the geometry parameters of all active and inactive initial condition patches. impure subroutine s_check_patches integer :: i @@ -125,8 +125,7 @@ contains end subroutine s_check_patches - !> This subroutine checks the line segment patch input - !! @param patch_id Patch identifier + !> Check the line segment patch input impure subroutine s_check_line_segment_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -141,8 +140,7 @@ contains end subroutine s_check_line_segment_patch_geometry - !> This subroutine checks the circle patch input - !! @param patch_id Patch identifier + !> Check the circle patch input impure subroutine s_check_circle_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -157,8 +155,7 @@ contains end subroutine s_check_circle_patch_geometry - !> This subroutine checks the rectangle patch input - !! @param patch_id Patch identifier + !> Check the rectangle patch input impure subroutine s_check_rectangle_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -174,8 +171,7 @@ contains end subroutine s_check_rectangle_patch_geometry - !> This subroutine checks the line sweep patch input - !! @param patch_id Patch identifier + !> Check the line sweep patch input impure subroutine s_check_line_sweep_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -193,8 +189,7 @@ contains end subroutine s_check_line_sweep_patch_geometry - !> This subroutine checks the ellipse patch input - !! @param patch_id Patch identifier + !> Check the ellipse patch input impure subroutine s_check_ellipse_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -211,8 +206,7 @@ contains end subroutine s_check_ellipse_patch_geometry - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> Check the model patch input impure subroutine s_check_2D_TaylorGreen_vortex_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -234,8 +228,7 @@ contains end subroutine s_check_2D_TaylorGreen_vortex_patch_geometry - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> Check the model patch input impure subroutine s_check_sphere_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -282,8 +275,7 @@ contains end subroutine s_check_3d_spherical_harmonic_patch_geometry - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> Check the model patch input impure subroutine s_check_cuboid_patch_geometry(patch_id) ! Patch identifier @@ -301,8 +293,7 @@ contains end subroutine s_check_cuboid_patch_geometry - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> Check the model patch input impure subroutine s_check_cylinder_patch_geometry(patch_id) ! Patch identifier @@ -330,8 +321,7 @@ contains end subroutine s_check_cylinder_patch_geometry - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> Check the model patch input impure subroutine s_check_plane_sweep_patch_geometry(patch_id) ! Patch identifier @@ -349,8 +339,7 @@ contains end subroutine s_check_plane_sweep_patch_geometry - !> This subroutine checks the model patch input - !! @param patch_id Patch identifier + !> Check the model patch input impure subroutine s_check_ellipsoid_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -396,8 +385,7 @@ contains end subroutine s_check_inactive_patch_geometry - !> This subroutine verifies the active patch's right to overwrite the preceding patches - !! @param patch_id Patch identifier + !> Verify the active patch's right to overwrite the preceding patches impure subroutine s_check_active_patch_alteration_rights(patch_id) integer, intent(in) :: patch_id @@ -411,8 +399,7 @@ contains end subroutine s_check_active_patch_alteration_rights - !> This subroutine verifies that inactive patches cannot overwrite other patches - !! @param patch_id Patch identifier + !> Verify that inactive patches cannot overwrite other patches impure subroutine s_check_inactive_patch_alteration_rights(patch_id) ! Patch identifier @@ -426,8 +413,7 @@ contains end subroutine s_check_inactive_patch_alteration_rights - !> This subroutine checks the smoothing parameters - !! @param patch_id Patch identifier + !> Check the smoothing parameters impure subroutine s_check_supported_patch_smoothing(patch_id) integer, intent(in) :: patch_id @@ -450,8 +436,7 @@ contains end subroutine s_check_supported_patch_smoothing - !> This subroutine verifies that inactive patches cannot be smoothed - !! @param patch_id Patch identifier + !> Verify that inactive patches cannot be smoothed impure subroutine s_check_unsupported_patch_smoothing(patch_id) ! Patch identifier @@ -467,8 +452,7 @@ contains end subroutine s_check_unsupported_patch_smoothing - !> This subroutine checks the primitive variables - !! @param patch_id Patch identifier + !> Check the primitive variables impure subroutine s_check_active_patch_primitive_variables(patch_id) integer, intent(in) :: patch_id @@ -520,9 +504,7 @@ contains end subroutine s_check_active_patch_primitive_variables - !> This subroutine verifies that the primitive variables associated with the given inactive patch remain unaltered by the user - !! inputs. - !! @param patch_id Patch identifier + !> Verify that the primitive variables associated with the given inactive patch remain unaltered by the user inputs. impure subroutine s_check_inactive_patch_primitive_variables(patch_id) integer, intent(in) :: patch_id @@ -540,7 +522,7 @@ contains end subroutine s_check_inactive_patch_primitive_variables - !> @brief Verifies that the model file referenced by the given patch exists on disk. + !> Verify that the model file referenced by the given patch exists on disk. impure subroutine s_check_model_geometry(patch_id) integer, intent(in) :: patch_id diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index 9cc26a2342..c90b7f4661 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -33,7 +33,6 @@ module m_data_output abstract interface !> Interface for the conservative data - !! @param q_cons_vf Conservative variables impure subroutine s_write_abstract_data_files(q_cons_vf, q_prim_vf, bc_type) import :: scalar_field, integer_field, sys_size, m, n, p, pres_field, num_dims @@ -52,9 +51,6 @@ module m_data_output contains !> Writes grid and initial condition data files to the "0" time-step directory in the local processor rank folder - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Primitive variables - !! @param bc_type Boundary condition types impure subroutine s_write_serial_data_files(q_cons_vf, q_prim_vf, bc_type) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf @@ -384,9 +380,6 @@ contains end subroutine s_write_serial_data_files !> Writes grid and initial condition data files in parallel to the "0" time-step directory in the local processor rank folder - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Primitive variables - !! @param bc_type Boundary condition types impure subroutine s_write_parallel_data_files(q_cons_vf, q_prim_vf, bc_type) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 89e986cf0f..caaf97d69f 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -888,7 +888,7 @@ contains end subroutine s_initialize_global_parameters_module - !> @brief Configures MPI parallel I/O settings and allocates processor coordinate arrays. + !> Configure MPI parallel I/O settings and allocate processor coordinate arrays. impure subroutine s_initialize_parallel_io #ifdef MFC_MPI @@ -922,7 +922,7 @@ contains end subroutine s_initialize_parallel_io - !> @brief Deallocates all global grid, index, and equation-of-state parameter arrays. + !> Deallocate all global grid, index, and equation-of-state parameter arrays. impure subroutine s_finalize_global_parameters_module integer :: i diff --git a/src/pre_process/m_grid.f90 b/src/pre_process/m_grid.f90 index 927c5961b8..77cb02cef2 100644 --- a/src/pre_process/m_grid.f90 +++ b/src/pre_process/m_grid.f90 @@ -20,7 +20,7 @@ module m_grid abstract interface - !> @brief Abstract interface for generating a rectilinear computational grid. + !> Abstract interface for generating a rectilinear computational grid. impure subroutine s_generate_abstract_grid end subroutine s_generate_abstract_grid @@ -30,9 +30,7 @@ end subroutine s_generate_abstract_grid contains - !> The following subroutine generates either a uniform or non-uniform rectilinear grid in serial, defined by the parameters - !! inputted by the user. The grid information is stored in the grid variables containing coordinates of the cell- centers and - !! cell-boundaries. + !> Generate a uniform or stretched rectilinear grid in serial from user parameters. impure subroutine s_generate_serial_grid ! Generic loop iterator @@ -154,9 +152,7 @@ impure subroutine s_generate_serial_grid end subroutine s_generate_serial_grid - !> The following subroutine generates either a uniform or non-uniform rectilinear grid in parallel, defined by the parameters - !! inputted by the user. The grid information is stored in the grid variables containing coordinates of the cell- centers and - !! cell-boundaries. + !> Generate a uniform or stretched rectilinear grid in parallel from user parameters. impure subroutine s_generate_parallel_grid #ifdef MFC_MPI diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index c0ba4a45da..a2274c02fa 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -49,7 +49,7 @@ module m_icpp_patches contains - !> @brief Dispatches each initial condition patch to its geometry-specific initialization routine. + !> Dispatch each initial condition patch to its geometry-specific initialization routine. impure subroutine s_apply_icpp_patches(patch_id_fp, q_prim_vf) type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf @@ -165,9 +165,6 @@ contains !> The line segment patch is a 1D geometry that may be used, for example, in creating a Riemann problem. The geometry of the !! patch is well-defined when its centroid and length in the x-coordinate direction are provided. Note that the line segment !! patch DOES NOT allow for the smearing of its boundaries. - !! @param patch_id patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_line_segment(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -228,9 +225,6 @@ contains !> The spiral patch is a 2D geometry that may be used, The geometry of the patch is well-defined when its centroid and radius !! are provided. Note that the circular patch DOES allow for the smoothing of its boundary. - !! @param patch_id patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables impure subroutine s_icpp_spiral(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -296,9 +290,6 @@ contains !> The circular patch is a 2D geometry that may be used, for example, in creating a bubble or a droplet. The geometry of the !! patch is well-defined when its centroid and radius are provided. Note that the circular patch DOES allow for the smoothing of !! its boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_circle(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -352,9 +343,6 @@ contains end subroutine s_icpp_circle !> The varcircle patch is a 2D geometry that may be used . It generatres an annulus - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_varcircle(patch_id, patch_id_fp, q_prim_vf) ! Patch identifier @@ -411,10 +399,7 @@ contains end subroutine s_icpp_varcircle - !> @brief Initializes a 3D variable-thickness circular annulus patch extruded along the z-axis. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !> Initialize a 3D variable-thickness circular annulus patch extruded along the z-axis. subroutine s_icpp_3dvarcircle(patch_id, patch_id_fp, q_prim_vf) ! Patch identifier @@ -479,9 +464,6 @@ contains !> The elliptical patch is a 2D geometry. The geometry of the patch is well-defined when its centroid and radii are provided. !! Note that the elliptical patch DOES allow for the smoothing of its boundary - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_ellipse(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -538,9 +520,6 @@ contains !> The ellipsoidal patch is a 3D geometry. The geometry of the patch is well-defined when its centroid and radii are provided. !! Note that the ellipsoidal patch DOES allow for the smoothing of its boundary - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_ellipsoid(patch_id, patch_id_fp, q_prim_vf) ! Patch identifier @@ -614,9 +593,6 @@ contains !! region, in alignment with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x- and y- coordinate directions are provided. Please note that the rectangular patch DOES NOT !! allow for the smoothing of its boundaries. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_rectangle(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -687,9 +663,6 @@ contains !! region, at an angle with respect to the axes of the Cartesian coordinate system. The geometry of the patch is well-defined !! when its centroid and normal vector, aimed in the sweep direction, are provided. Note that the sweep line patch DOES allow !! the smoothing of its boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_sweep_line(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -747,9 +720,6 @@ contains !> The Taylor Green vortex is 2D decaying vortex that may be used, for example, to verify the effects of viscous attenuation. !! Geometry of the patch is well-defined when its centroid are provided. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_2D_TaylorGreen_Vortex(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -817,10 +787,7 @@ contains end subroutine s_icpp_2D_TaylorGreen_Vortex - !> @brief Initializes a 1D bubble-pulse patch with analytical primitive variable profiles. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables + !> Initialize a 1D bubble-pulse patch with analytical primitive variable profiles. subroutine s_icpp_1d_bubble_pulse(patch_id, patch_id_fp, q_prim_vf) ! Description: This patch assigns the primitive variables as analytical functions such that the code can be verified. @@ -997,9 +964,6 @@ contains !> The spherical patch is a 3D geometry that may be used, for example, in creating a bubble or a droplet. The patch geometry is !! well-defined when its centroid and radius are provided. Please note that the spherical patch DOES allow for the smoothing of !! its boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_sphere(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -1070,9 +1034,6 @@ contains !! which is aligned with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its !! centroid and lengths in the x-, y- and z-coordinate directions are provided. Please notice that the cuboidal patch DOES NOT !! allow for the smearing of its boundaries. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_cuboid(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -1143,9 +1104,6 @@ contains !! like a blood vessel. The geometry of this patch is well-defined when the centroid, the radius and the length along the !! cylinder's axis, parallel to the x-, y- or z-coordinate direction, are provided. Please note that the cylindrical patch DOES !! allow for the smoothing of its lateral boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Array of primitive variables subroutine s_icpp_cylinder(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -1241,9 +1199,6 @@ contains !! region, at an angle with respect to the axes of the Cartesian coordinate system. The geometry of the patch is well-defined !! when its centroid and normal vector, aimed in the sweep direction, are provided. Note that the sweep plane patch DOES allow !! the smoothing of its boundary. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Primitive variables subroutine s_icpp_sweep_plane(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -1312,9 +1267,6 @@ contains end subroutine s_icpp_sweep_plane !> The STL patch is a 2/3D geometry that is imported from an STL file. - !! @param patch_id is the patch identifier - !! @param patch_id_fp Array to track patch ids - !! @param q_prim_vf Primitive variables subroutine s_icpp_model(patch_id, patch_id_fp, q_prim_vf) integer, intent(in) :: patch_id @@ -1440,7 +1392,7 @@ contains end subroutine s_icpp_model - !> @brief Converts cylindrical (r, theta) coordinates to Cartesian (y, z) module variables. + !> Convert cylindrical (r, theta) coordinates to Cartesian (y, z) module variables. subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) $:GPU_ROUTINE(parallelism='[seq]') @@ -1452,7 +1404,7 @@ contains end subroutine s_convert_cylindrical_to_cartesian_coord - !> @brief Returns a 3D Cartesian coordinate vector from a cylindrical (x, r, theta) input vector. + !> Return a 3D Cartesian coordinate vector from a cylindrical (x, r, theta) input vector. function f_convert_cyl_to_cart(cyl) result(cart) $:GPU_ROUTINE(parallelism='[seq]') @@ -1464,7 +1416,7 @@ contains end function f_convert_cyl_to_cart - !> @brief Computes the spherical azimuthal angle from cylindrical (x, r) coordinates. + !> Compute the spherical azimuthal angle from cylindrical (x, r) coordinates. subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) $:GPU_ROUTINE(parallelism='[seq]') @@ -1476,9 +1428,6 @@ contains end subroutine s_convert_cylindrical_to_spherical_coord !> Archimedes spiral function - !! @param myth Angle - !! @param offset Thickness - !! @param a Starting position elemental function f_r(myth, offset, a) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 42bdb0ff88..2d95d7d0d1 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -119,9 +119,9 @@ contains end subroutine s_initialize_initial_condition_module - !> This subroutine peruses the patches and depending on the type of geometry associated with a particular patch, it calls the - !! related subroutine to setup the said geometry on the grid using the primitive variables included with the patch parameters. - !! The subroutine is complete once the primitive variables are converted to conservative ones. + !> Iterate over patches and, depending on the geometry type, call the related subroutine to setup the said geometry on the grid + !! using the primitive variables included with the patch parameters. The subroutine is complete once the primitive variables are + !! converted to conservative ones. impure subroutine s_generate_initial_condition integer :: i diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index 24ee888966..81afa0b24f 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -19,7 +19,7 @@ module m_perturbation contains - !> @brief Allocates the temporary primitive variable array used by elliptic smoothing. + !> Allocate the temporary primitive variable array used by elliptic smoothing. impure subroutine s_initialize_perturbation_module() if (elliptic_smoothing) then @@ -28,7 +28,7 @@ contains end subroutine s_initialize_perturbation_module - !> @brief Randomly perturbs partial density fields at the interface of a spherical volume fraction region. + !> Randomly perturb partial density fields at the interface of a spherical volume fraction region. impure subroutine s_perturb_sphere(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -58,7 +58,7 @@ contains end subroutine s_perturb_sphere - !> @brief Adds random noise to the velocity and void fraction of the surrounding flow field. + !> Add random noise to the velocity and void fraction of the surrounding flow field. impure subroutine s_perturb_surrounding_flow(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -85,7 +85,7 @@ contains end subroutine s_perturb_surrounding_flow - !> @brief Iteratively smooths all primitive variable fields using a discrete elliptic (Laplacian) filter. + !> Iteratively smooth all primitive variable fields using a discrete elliptic (Laplacian) filter. impure subroutine s_elliptic_smoothing(q_prim_vf, bc_type) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -143,7 +143,7 @@ contains end subroutine s_elliptic_smoothing - !> @brief Perturbs velocity and volume fraction fields using multi-octave simplex noise. + !> Perturb velocity and volume fraction fields using multi-octave simplex noise. subroutine s_perturb_simplex(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -229,9 +229,8 @@ contains end subroutine s_perturb_simplex - !> This subroutine computes velocity perturbations for a temporal mixing layer with a hyperbolic tangent mean streamwise - !! velocity profile, using an inverted version of the spectrum-based synthetic turbulence generation method proposed by Guo et - !! al. (2023, JFM). + !> Compute velocity perturbations for a temporal mixing layer with a hyperbolic tangent mean streamwise velocity profile, using + !! an inverted version of the spectrum-based synthetic turbulence generation method proposed by Guo et al. (2023, JFM). subroutine s_perturb_mixlayer(q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -308,7 +307,7 @@ contains end subroutine s_perturb_mixlayer - !> @brief Generates deterministic pseudo-random wave vector, polarization, and phase for a perturbation mode. + !> Generate deterministic pseudo-random wave vector, polarization, and phase for a perturbation mode. subroutine s_generate_random_perturbation(khat, xi, phi, ik, yloc) integer, intent(in) :: ik @@ -334,7 +333,7 @@ contains end subroutine s_generate_random_perturbation - !> @brief Generates a unit vector uniformly distributed on the sphere from two random parameters. + !> Generate a unit vector uniformly distributed on the sphere from two random parameters. function f_unit_vector(theta, eta) result(vec) real(wp), intent(in) :: theta, eta @@ -349,7 +348,7 @@ contains end function f_unit_vector - !> This function generates a pseudo-random number between 0 and 1 based on linear congruential generator. + !> Generate a pseudo-random number between 0 and 1 using a linear congruential generator. subroutine s_prng(var, seed) integer, intent(inout) :: seed @@ -361,7 +360,7 @@ contains end subroutine s_prng - !> @brief Computes a modular multiplication step for the linear congruential pseudo-random number generator. + !> Compute a modular multiplication step for the linear congruential pseudo-random number generator. function modmul(a) result(val) integer, intent(in) :: a @@ -374,7 +373,7 @@ contains end function modmul - !> @brief Deallocates the temporary primitive variable array used by elliptic smoothing. + !> Deallocate the temporary primitive variable array used by elliptic smoothing. impure subroutine s_finalize_perturbation_module() if (elliptic_smoothing) then diff --git a/src/pre_process/m_simplex_noise.fpp b/src/pre_process/m_simplex_noise.fpp index 487b4f5022..fb5ebcf226 100644 --- a/src/pre_process/m_simplex_noise.fpp +++ b/src/pre_process/m_simplex_noise.fpp @@ -47,7 +47,7 @@ module m_simplex_noise contains - !> @brief Evaluates 3D simplex noise at the given coordinates and returns a value in [-1, 1]. + !> Evaluate 3D simplex noise at the given coordinates and return a value in [-1, 1]. function f_simplex3d(xin, yin, zin) result(n) real(wp), intent(in) :: xin, yin, zin @@ -148,7 +148,7 @@ contains end function f_simplex3d - !> @brief Evaluates 2D simplex noise at the given coordinates and returns a value in [-1, 1]. + !> Evaluate 2D simplex noise at the given coordinates and return a value in [-1, 1]. function f_simplex2d(xin, yin) result(n) real(wp), intent(in) :: xin, yin @@ -215,7 +215,7 @@ contains end function f_simplex2d - !> @brief Computes the dot product of a 2D gradient vector with the given offset coordinates. + !> Compute the dot product of a 2D gradient vector with the given offset coordinates. function dot2(g, x, y) result(dot) integer, intent(in) :: g diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 649887306e..51a6f66730 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -43,13 +43,12 @@ module m_start_up abstract interface - !> @brief Abstract interface for reading grid data files in serial or parallel. + !> Abstract interface for reading grid data files in serial or parallel. impure subroutine s_read_abstract_grid_data_files end subroutine s_read_abstract_grid_data_files - !> @brief Abstract interface for reading initial condition data files in serial or parallel. - !! @param q_cons_vf Conservative variables + !> Abstract interface for reading initial condition data files in serial or parallel. impure subroutine s_read_abstract_ic_data_files(q_cons_vf_in) import :: scalar_field, integer_field, sys_size, pres_field @@ -264,7 +263,6 @@ contains !> The goal of this subroutine is to read in any preexisting initial condition data files so that they may be used by the !! pre-process as a starting point in the creation of an all new initial condition. - !! @param q_cons_vf_in Conservative variables impure subroutine s_read_serial_ic_data_files(q_cons_vf_in) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in @@ -412,7 +410,6 @@ contains !> The goal of this subroutine is to read in any preexisting initial condition data files so that they may be used by the !! pre-process as a starting point in the creation of an all new initial condition. - !! @param q_cons_vf_in Conservative variables impure subroutine s_read_parallel_ic_data_files(q_cons_vf_in) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf_in @@ -487,7 +484,7 @@ contains end subroutine s_read_parallel_ic_data_files - !> @brief Initializes all pre-process modules, allocates data structures, and sets I/O procedure pointers. + !> Initialize all pre-process modules, allocate data structures, and set I/O procedure pointers. impure subroutine s_initialize_modules call s_initialize_global_parameters_module() @@ -521,7 +518,7 @@ contains end subroutine s_initialize_modules - !> @brief Reads an existing grid from data files or generates a new grid from user inputs. + !> Read an existing grid from data files or generate a new grid from user inputs. impure subroutine s_read_grid() if (old_grid) then @@ -540,7 +537,7 @@ contains end subroutine s_read_grid - !> @brief Generates or reads the initial condition, applies relaxation if needed, and writes output data files. + !> Generate or read the initial condition, apply relaxation if needed, and write output data files. impure subroutine s_apply_initial_condition(start, finish) real(wp), intent(inout) :: start, finish @@ -583,7 +580,7 @@ contains end subroutine s_apply_initial_condition - !> @brief Gathers processor timing data and writes elapsed wall-clock time to a summary file. + !> Gather processor timing data and write elapsed wall-clock time to a summary file. impure subroutine s_save_data(proc_time, time_avg, time_final, file_exists) real(wp), dimension(:), intent(inout) :: proc_time @@ -619,7 +616,7 @@ contains end subroutine s_save_data - !> @brief Initializes MPI, reads and validates user inputs on rank 0, and decomposes the computational domain. + !> Initialize MPI, read and validate user inputs on rank 0, and decompose the computational domain. impure subroutine s_initialize_mpi_domain call s_mpi_initialize() @@ -640,7 +637,7 @@ contains end subroutine s_initialize_mpi_domain - !> @brief Finalizes all pre-process modules, deallocates resources, and shuts down MPI. + !> Finalize all pre-process modules, deallocate resources, and shut down MPI. impure subroutine s_finalize_modules s_generate_grid => null() diff --git a/src/pre_process/p_main.f90 b/src/pre_process/p_main.f90 index c61b120f09..e16ff68571 100644 --- a/src/pre_process/p_main.f90 +++ b/src/pre_process/p_main.f90 @@ -2,7 +2,7 @@ !! @file !! @brief Contains program p_main -!> @brief This program takes care of setting up the initial condition and grid data for the multicomponent flow code. +!> @brief Set up the initial condition and grid data for the multicomponent flow code. program p_main use m_global_parameters diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index 40fb9593e7..c982ffbd62 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -57,7 +57,7 @@ module m_acoustic_src contains - !> This subroutine initializes the acoustic source module + !> Initialize the acoustic source module impure subroutine s_initialize_acoustic_src integer :: i, j !< generic loop variables @@ -121,10 +121,7 @@ contains end subroutine s_initialize_acoustic_src - !> This subroutine updates the rhs by computing the mass, mom, energy sources - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Primitive variables - !! @param rhs_vf rhs variables + !> Compute mass, momentum, and energy acoustic source terms and add to the RHS impure subroutine s_acoustic_src_calculations(q_cons_vf, q_prim_vf, rhs_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Conservative variables @@ -331,15 +328,7 @@ contains end subroutine s_acoustic_src_calculations - !> This subroutine gives the temporally varying amplitude of the pulse - !! @param sim_time Simulation time - !! @param c Sound speed - !! @param ai Acoustic source index - !! @param term_index Index of the term to be calculated (1: mass source, 2: momentum source) - !! @param frequency_local Frequency at the spatial location for sine and square waves - !! @param gauss_sigma_time_local sigma in time for Gaussian pulse - !! @param source Source term amplitude - !! @param sum_bb Sum of basis functions + !> Compute the temporally varying amplitude of the pulse elemental subroutine s_source_temporal(sim_time, c, ai, term_index, frequency_local, gauss_sigma_time_local, source, sum_BB) $:GPU_ROUTINE(parallelism='[seq]') @@ -485,15 +474,7 @@ contains end subroutine s_precalculate_acoustic_spatial_sources - !> This subroutine gives the spatial support of the acoustic source - !! @param j x-index - !! @param k y-index - !! @param l z-index - !! @param loc Nominal source term location - !! @param ai Acoustic source index - !! @param source Source term amplitude - !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) - !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) + !> Compute the spatial support of the acoustic source subroutine s_source_spatial(j, k, l, loc, ai, source, angle, xyz_to_r_ratios) integer, intent(in) :: j, k, l, ai @@ -527,11 +508,7 @@ contains end subroutine s_source_spatial - !> This subroutine calculates the spatial support for planar acoustic sources in 1D, 2D, and 3D - !! @param ai Acoustic source index - !! @param sig Sigma value for the Gaussian distribution - !! @param r Displacement from source to current point - !! @param source Source term amplitude + !> Compute the spatial support for planar acoustic sources in 1D, 2D, and 3D subroutine s_source_spatial_planar(ai, sig, r, source) integer, intent(in) :: ai @@ -557,13 +534,7 @@ contains end subroutine s_source_spatial_planar - !> This subroutine calculates the spatial support for a single transducer in 2D, 2D axisymmetric, and 3D - !! @param ai Acoustic source index - !! @param sig Sigma value for the Gaussian distribution - !! @param r Displacement from source to current point - !! @param source Source term amplitude - !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) - !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) + !> Compute the spatial support for a single transducer in 2D, 2D axisymmetric, and 3D subroutine s_source_spatial_transducer(ai, sig, r, source, angle, xyz_to_r_ratios) integer, intent(in) :: ai @@ -601,13 +572,7 @@ contains end subroutine s_source_spatial_transducer - !> This subroutine calculates the spatial support for multiple transducers in 2D, 2D axisymmetric, and 3D - !! @param ai Acoustic source index - !! @param sig Sigma value for the Gaussian distribution - !! @param r Displacement from source to current point - !! @param source Source term amplitude - !! @param angle Angle of the source term with respect to the x-axis (for 2D or 2D axisymmetric) - !! @param xyz_to_r_ratios Ratios of the [xyz]-component of the source term to the magnitude (for 3D) + !> Compute the spatial support for multiple transducers in 2D, 2D axisymmetric, and 3D subroutine s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios) integer, intent(in) :: ai @@ -683,11 +648,7 @@ contains end subroutine s_source_spatial_transducer_array - !> This function performs wavelength to frequency conversion - !! @param freq_conv_flag Determines if frequency is given or wavelength - !! @param ai Acoustic source index - !! @param c Speed of sound - !! @return frequency_local Converted frequency + !> Convert wavelength to frequency elemental function f_frequency_local(freq_conv_flag, ai, c) $:GPU_ROUTINE(parallelism='[seq]') @@ -704,11 +665,7 @@ contains end function f_frequency_local - !> This function performs Gaussian sigma dist to time conversion - !! @param gauss_conv_flag Determines if sigma_dist is given or sigma_time - !! @param c Speed of sound - !! @param ai Acoustic source index - !! @return gauss_sigma_time_local Converted Gaussian sigma time + !> Convert Gaussian sigma from distance to time function f_gauss_sigma_time_local(gauss_conv_flag, ai, c) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_body_forces.fpp b/src/simulation/m_body_forces.fpp index e061608c7e..7200390c2c 100644 --- a/src/simulation/m_body_forces.fpp +++ b/src/simulation/m_body_forces.fpp @@ -24,7 +24,7 @@ module m_body_forces contains - !> This subroutine initializes the module global array of mixture densities in each grid cell + !> Initialize the body forces module impure subroutine s_initialize_body_forces_module if (n > 0) then @@ -39,7 +39,7 @@ contains end subroutine s_initialize_body_forces_module - !> This subroutine computes the acceleration at time t + !> Compute the acceleration at time t subroutine s_compute_acceleration(t) real(wp), intent(in) :: t @@ -54,8 +54,7 @@ contains end subroutine s_compute_acceleration - !> This subroutine calculates the mixture density at each cell center - !! @param q_cons_vf Conservative variables + !> Compute the mixture density at each cell center subroutine s_compute_mixture_density(q_cons_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -76,10 +75,7 @@ contains end subroutine s_compute_mixture_density - !> This subroutine calculates the source term due to body forces so the system can be advanced in time - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Primitive variables - !! @param rhs_vf Right-hand side accumulator + !> Compute the body force source terms for momentum and energy equations subroutine s_compute_body_forces_rhs(q_prim_vf, q_cons_vf, rhs_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -146,7 +142,7 @@ contains end subroutine s_compute_body_forces_rhs - !> @brief Deallocates module variables used for body force computations. + !> Finalize the body forces module impure subroutine s_finalize_body_forces_module @:DEALLOCATE(rhoM) diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index 771059b750..ae9faaa2cf 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -22,20 +22,7 @@ module m_bubbles contains - !> Function that computes the bubble radial acceleration based on bubble models - !! @param fRho Current density - !! @param fP Current driving pressure - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpb Internal bubble pressure - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param alf bubble volume fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param f_bub_adv_src Source for bubble volume fraction - !! @param f_divu Divergence of velocity - !! @param fCson Speed of sound from fP (EL) + !> Compute the bubble radial acceleration based on the selected bubble model elemental function f_rddot(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson) $:GPU_ROUTINE(parallelism='[seq]') @@ -76,10 +63,6 @@ contains end function f_rddot !> Bubble wall pressure: stiffened gas with Laplace pressure and viscous stress - !! @param fR0 Equilibrium bubble radius - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fpb Internal bubble pressure elemental function f_cpbw(fR0, fR, fV, fpb) $:GPU_ROUTINE(parallelism='[seq]') @@ -94,11 +77,7 @@ contains end function f_cpbw - !> Function that computes the bubble enthalpy - !! @param fCpbw Bubble wall pressure - !! @param fCpinf Driving bubble pressure - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter + !> Compute the bubble enthalpy elemental function f_H(fCpbw, fCpinf, fntait, fBtait) $:GPU_ROUTINE(parallelism='[seq]') @@ -114,11 +93,7 @@ contains end function f_H - !> Function that computes the sound speed for the bubble - !! @param fCpinf Driving bubble pressure - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param fH Bubble enthalpy + !> Compute the sound speed for the bubble elemental function f_cgas(fCpinf, fntait, fBtait, fH) $:GPU_ROUTINE(parallelism='[seq]') @@ -134,14 +109,7 @@ contains end function f_cgas - !> Function that computes the time derivative of the driving pressure - !! @param fRho Local liquid density - !! @param fP Local pressure - !! @param falf Local void fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param advsrc Advection equation source term - !! @param divu Divergence of velocity + !> Compute the time derivative of the driving pressure elemental function f_cpinfdot(fRho, fP, falf, fntait, fBtait, advsrc, divu) $:GPU_ROUTINE(parallelism='[seq]') @@ -162,15 +130,6 @@ contains end function f_cpinfdot !> Enthalpy derivative for Gilmore bubble model, Gilmore (1952) - !! @param fCpbw Bubble wall pressure - !! @param fCpinf Driving bubble pressure - !! @param fCpinf_dot Time derivative of the driving pressure - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpbdot Time derivative of the internal bubble pressure elemental function f_Hdot(fCpbw, fCpinf, fCpinf_dot, fntait, fBtait, fR, fV, fR0, fpbdot) $:GPU_ROUTINE(parallelism='[seq]') @@ -193,11 +152,6 @@ contains end function f_Hdot !> Rayleigh-Plesset bubble radial acceleration - !! @param fCp Driving pressure - !! @param fRho Current density - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fCpbw Boundary wall pressure elemental function f_rddot_RP(fCp, fRho, fR, fV, fCpbw) $:GPU_ROUTINE(parallelism='[seq]') @@ -208,15 +162,7 @@ contains end function f_rddot_RP - !> Function that computes the bubble radial acceleration - !! @param fCpbw Bubble wall pressure - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fH Current enthalpy - !! @param fHdot Current time derivative of the enthalpy - !! @param fcgas Current gas sound speed - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter + !> Compute the Gilmore bubble radial acceleration elemental function f_rddot_G(fCpbw, fR, fV, fH, fHdot, fcgas, fntait, fBtait) $:GPU_ROUTINE(parallelism='[seq]') @@ -234,10 +180,6 @@ contains end function f_rddot_G !> Keller-Miksis bubble wall pressure - !! @param fR0 Equilibrium bubble radius - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fpb Internal bubble pressure elemental function f_cpbw_KM(fR0, fR, fV, fpb) $:GPU_ROUTINE(parallelism='[seq]') @@ -257,14 +199,6 @@ contains end function f_cpbw_KM !> Keller-Miksis bubble radial acceleration - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param fCp Driving pressure - !! @param fCpbw Bubble wall pressure - !! @param fRho Current density - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fC Current sound speed elemental function f_rddot_KM(fpbdot, fCp, fCpbw, fRho, fR, fV, fR0, fC) $:GPU_ROUTINE(parallelism='[seq]') @@ -293,9 +227,7 @@ contains end function f_rddot_KM - !> Subroutine that computes bubble wall properties for vapor bubbles - !! @param pb_in Internal bubble pressure - !! @param iR0 Current bubble size index + !> Compute bubble wall properties for vapor bubbles elemental subroutine s_bwproperty(pb_in, iR0, chi_vw_out, k_mw_out, rho_mw_out) $:GPU_ROUTINE(parallelism='[seq]') @@ -316,17 +248,7 @@ contains end subroutine s_bwproperty - !> Function that computes the vapour flux - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fpb - !! @param fmass_v Current mass of vapour - !! @param iR0 Bubble size index (EE) or bubble identifier (EL) - !! @param vflux Computed vapour flux - !! @param fmass_g Current gas mass (EL) - !! @param fbeta_c Mass transfer coefficient (EL) - !! @param fR_m Mixture gas constant (EL) - !! @param fgamma_m Mixture gamma (EL) + !> Compute the vapour flux elemental subroutine s_vflux(fR, fV, fpb, fmass_v, iR0, vflux, fmass_g, fbeta_c, fR_m, fgamma_m) $:GPU_ROUTINE(parallelism='[seq]') @@ -374,16 +296,7 @@ contains end subroutine s_vflux - !> Function that computes the time derivative of the internal bubble pressure - !! @param fvflux Vapour flux - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fpb Current internal bubble pressure - !! @param fmass_v Current mass of vapour - !! @param iR0 Bubble size index (EE) or bubble identifier (EL) - !! @param fbeta_t Mass transfer coefficient (EL) - !! @param fR_m Mixture gas constant (EL) - !! @param fgamma_m Mixture gamma (EL) + !> Compute the time derivative of the internal bubble pressure elemental function f_bpres_dot(fvflux, fR, fV, fpb, fmass_v, iR0, fbeta_t, fR_m, fgamma_m) $:GPU_ROUTINE(parallelism='[seq]') @@ -418,25 +331,6 @@ contains !> Adaptive time stepping routine for subgrid bubbles (See Heirer, E. Hairer S.P.Norsett G. Wanner, Solving Ordinary !! Differential Equations I, Chapter II.4) - !! @param fRho Current density - !! @param fP Current driving pressure - !! @param fR Current bubble radius - !! @param fV Current bubble radial velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpb Internal bubble pressure - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param alf bubble volume fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param f_bub_adv_src Source for bubble volume fraction - !! @param f_divu Divergence of velocity - !! @param bub_id Bubble identifier (EL) - !! @param fmass_v Current mass of vapour (EL) - !! @param fmass_g Current mass of gas (EL) - !! @param fbeta_c Mass transfer coefficient (EL) - !! @param fbeta_t Heat transfer coefficient (EL) - !! @param fCson Speed of sound (EL) - !! @param adap_dt_stop Fail-safe exit if max iteration count reached subroutine s_advance_step(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, bub_id, fmass_v, & & fmass_g, fbeta_c, fbeta_t, fCson, adap_dt_stop) @@ -547,20 +441,6 @@ contains !> Choose the initial time step size for the adaptive time stepping routine (See Heirer, E. Hairer S.P.Norsett G. Wanner, !! Solving Ordinary Differential Equations I, Chapter II.4) - !! @param fRho Current density - !! @param fP Current driving pressure - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpb Internal bubble pressure - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param alf bubble volume fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param f_bub_adv_src Source for bubble volume fraction - !! @param f_divu Divergence of velocity - !! @param fCson Speed of sound (EL) - !! @param h Time step size subroutine s_initial_substep_h(fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, fCson, h) $:GPU_ROUTINE(function_name='s_initial_substep_h',parallelism='[seq]', cray_inline=True) @@ -606,30 +486,6 @@ contains end subroutine s_initial_substep_h !> Integrate bubble variables over the given time step size, h, using a third-order accurate embedded Runge-Kutta scheme. - !! @param err Estimated error - !! @param fRho Current density - !! @param fP Current driving pressure - !! @param fR Current bubble radius - !! @param fV Current bubble velocity - !! @param fR0 Equilibrium bubble radius - !! @param fpb Internal bubble pressure - !! @param fpbdot Time-derivative of internal bubble pressure - !! @param alf bubble volume fraction - !! @param fntait Tait EOS parameter - !! @param fBtait Tait EOS parameter - !! @param f_bub_adv_src Source for bubble volume fraction - !! @param f_divu Divergence of velocity - !! @param bub_id Bubble identifier (EL) - !! @param fmass_v Current mass of vapour (EL) - !! @param fmass_g Current mass of gas (EL) - !! @param fbeta_c Mass transfer coefficient (EL) - !! @param fbeta_t Heat transfer coefficient (EL) - !! @param fCson Speed of sound (EL) - !! @param h Time step size - !! @param myR_tmp Bubble radius at each stage - !! @param myV_tmp Bubble radial velocity at each stage - !! @param myPb_tmp Internal bubble pressure at each stage (EL) - !! @param myMv_tmp Mass of vapor in the bubble at each stage (EL) subroutine s_advance_substep(err, fRho, fP, fR, fV, fR0, fpb, fpbdot, alf, fntait, fBtait, f_bub_adv_src, f_divu, bub_id, & & fmass_v, fmass_g, fbeta_c, fbeta_t, fCson, h, myR_tmp, myV_tmp, myPb_tmp, myMv_tmp) @@ -720,16 +576,6 @@ contains end subroutine s_advance_substep !> Changes of pressure and vapor mass in the lagrange bubbles. - !! @param fR_tmp Bubble radius - !! @param fV_tmp Bubble radial velocity - !! @param fPb_tmp Internal bubble pressure - !! @param fMv_tmp Mass of vapor in the bubble - !! @param bub_id Bubble identifier - !! @param fmass_g Current mass of gas - !! @param fbeta_c Mass transfer coefficient - !! @param fbeta_t Heat transfer coefficient - !! @param fdPbdt_tmp Rate of change of the internal bubble pressure - !! @param advance_EL Rate of change of the mass of vapor in the bubble elemental subroutine s_advance_EL(fR_tmp, fV_tmp, fPb_tmp, fMv_tmp, bub_id, fmass_g, fbeta_c, fbeta_t, fdPbdt_tmp, advance_EL) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index 459bb51e92..8f3ae8fdab 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -26,7 +26,7 @@ module m_bubbles_EE contains - !> @brief Allocates and initializes arrays for the Euler-Euler bubble model. + !> Initialize the Euler-Euler bubble module impure subroutine s_initialize_bubbles_EE_module integer :: l @@ -64,8 +64,7 @@ contains end subroutine s_initialize_bubbles_EE_module - !> @brief Computes the bubble volume fraction alpha from the bubble number density. - !! @param q_cons_vf is the conservative variable + !> Compute the bubble volume fraction alpha from the bubble number density subroutine s_comp_alpha_from_n(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -90,8 +89,6 @@ contains end subroutine s_comp_alpha_from_n !> Compute the right-hand side for Euler-Euler bubble transport - !! @param idir Direction index - !! @param q_prim_vf Primitive variables subroutine s_compute_bubbles_EE_rhs(idir, q_prim_vf, divu_in) integer, intent(in) :: idir @@ -139,10 +136,7 @@ contains end subroutine s_compute_bubbles_EE_rhs - !> The purpose of this procedure is to compute the source terms that are needed for the bubble modeling - !! @param q_prim_vf Primitive variables - !! @param q_cons_vf Conservative variables - !! @param rhs_vf Right-hand side variables + !> Compute the Euler-Euler bubble source terms impure subroutine s_compute_bubble_EE_source(q_cons_vf, q_prim_vf, rhs_vf, divu_in) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 41942cd447..92153d91ab 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -67,7 +67,6 @@ module m_bubbles_EL contains !> Initializes the lagrangian subgrid bubble solver - !! @param q_cons_vf Initial conservative variables impure subroutine s_initialize_bubbles_EL_module(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -137,8 +136,7 @@ contains end subroutine s_initialize_bubbles_EL_module - !> The purpose of this procedure is to obtain the initial bubbles' information - !! @param q_cons_vf Conservative variables + !> Read initial bubble data from input files impure subroutine s_read_input_bubbles(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -223,10 +221,7 @@ contains end subroutine s_read_input_bubbles - !> The purpose of this procedure is to obtain the information of the bubbles when starting fresh - !! @param inputBubble Bubble information - !! @param q_cons_vf Conservative variables - !! @param bub_id Local id of the bubble + !> Add a new bubble from input data for a fresh start impure subroutine s_add_bubbles(inputBubble, q_cons_vf, bub_id) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -334,9 +329,7 @@ contains end subroutine s_add_bubbles - !> The purpose of this procedure is to obtain the information of the bubbles from a restart point. - !! @param bub_id Local ID of the particle - !! @param save_count File identifier + !> Restore bubble data from a restart file impure subroutine s_restart_bubbles(bub_id, save_count) integer, intent(inout) :: bub_id, save_count @@ -491,8 +484,6 @@ contains end subroutine s_restart_bubbles !> Contains the bubble dynamics subroutines. - !! @param q_prim_vf Primitive variables - !! @param stage Current stage in the time-stepper algorithm subroutine s_compute_bubble_EL_dynamics(q_prim_vf, stage) type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf @@ -614,11 +605,7 @@ contains end subroutine s_compute_bubble_EL_dynamics - !> The purpose of this subroutine is to obtain the bubble source terms based on Maeda and Colonius (2018) and add them to the - !! RHS scalar field. - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Conservative variables - !! @param rhs_vf Time derivative of the conservative variables + !> Compute the Lagrangian bubble source terms and add them to the RHS subroutine s_compute_bubbles_EL_source(q_cons_vf, q_prim_vf, rhs_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -710,14 +697,7 @@ contains end subroutine s_compute_bubbles_EL_source - !> This procedure computes the speed of sound from a given driving pressure - !! @param q_prim_vf Primitive variables - !! @param pinf Driving pressure - !! @param cell Bubble cell - !! @param rhol Liquid density - !! @param gamma Liquid specific heat ratio - !! @param pi_inf Liquid stiffness - !! @param cson Calculated speed of sound + !> Compute the speed of sound from a given driving pressure subroutine s_compute_cson_from_pinf(q_prim_vf, pinf, cell, rhol, gamma, pi_inf, cson) $:GPU_ROUTINE(function_name='s_compute_cson_from_pinf', parallelism='[seq]', cray_inline=True) @@ -745,7 +725,7 @@ contains end subroutine s_compute_cson_from_pinf - !> The purpose of this subroutine is to smear the effect of the bubbles in the Eulerian framework + !> Smear the bubble effects onto the Eulerian grid subroutine s_smear_voidfraction() integer :: i, j, k, l @@ -783,15 +763,7 @@ contains end subroutine s_smear_voidfraction - !> The purpose of this procedure is obtain the bubble driving pressure p_inf - !! @param bub_id Particle identifier - !! @param q_prim_vf Primitive variables - !! @param ptype 1: p at infinity, 2: averaged P at the bubble location - !! @param f_pinfl Driving pressure - !! @param cell Bubble cell - !! @param preterm1 Pre-computed term 1 - !! @param term2 Computed term 2 - !! @param Romega Control volume radius + !> Compute the bubble driving pressure p_inf subroutine s_get_pinf(bub_id, q_prim_vf, ptype, f_pinfl, cell, preterm1, term2, Romega) $:GPU_ROUTINE(function_name='s_get_pinf',parallelism='[seq]', cray_inline=True) @@ -994,9 +966,7 @@ contains end subroutine s_get_pinf - !> This subroutine updates the Lagrange variables using the tvd RK time steppers. The time derivative of the bubble variables - !! must be stored at every stage to avoid precision errors. - !! @param stage Current tvd RK stage + !> Update Lagrangian bubble variables using TVD Runge-Kutta time stepping impure subroutine s_update_lagrange_tdv_rk(stage) integer, intent(in) :: stage @@ -1113,10 +1083,7 @@ contains end subroutine s_update_lagrange_tdv_rk - !> This subroutine returns the computational coordinate of the cell for the given position. - !! @param pos Input coordinates - !! @param cell Computational coordinate of the cell - !! @param scoord Calculated particle coordinates + !> Locate the cell index for a given physical position subroutine s_locate_cell(pos, cell, scoord) real(wp), dimension(3), intent(in) :: pos @@ -1165,7 +1132,7 @@ contains end subroutine s_locate_cell - !> This subroutine transfer data into the temporal variables. + !> Transfer data into the temporal variables impure subroutine s_transfer_data_to_tmp() integer :: k @@ -1185,9 +1152,7 @@ contains end subroutine s_transfer_data_to_tmp - !> The purpose of this procedure is to determine if the global coordinates of the bubbles are present in the current MPI - !! processor (including ghost cells). - !! @param pos_part Spatial coordinates of the bubble + !> Determine if a bubble position lies within the current MPI subdomain including ghost cells function particle_in_domain(pos_part) logical :: particle_in_domain @@ -1239,9 +1204,7 @@ contains end function particle_in_domain - !> The purpose of this procedure is to determine if the lagrangian bubble is located in the physical domain. The ghost cells are - !! not part of the physical domain. - !! @param pos_part Spatial coordinates of the bubble + !> Determine if a Lagrangian bubble is within the physical domain excluding ghost cells function particle_in_domain_physical(pos_part) logical :: particle_in_domain_physical @@ -1257,11 +1220,7 @@ contains end function particle_in_domain_physical - !> The purpose of this procedure is to calculate the gradient of a scalar field along the x, y and z directions following a - !! second-order central difference considering uneven widths - !! @param q Input scalar field - !! @param dq Output gradient of q - !! @param dir Gradient spatial direction + !> Compute the gradient of a scalar field using second-order central differences on a non-uniform grid subroutine s_gradient_dir(q, dq, dir) real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:), intent(inout) :: q, dq @@ -1311,8 +1270,7 @@ contains end subroutine s_gradient_dir - !> Subroutine that writes on each time step the changes of the lagrangian bubbles. - !! @param qtime Current time + !> Write Lagrangian bubble state data at each time step impure subroutine s_write_lag_particles(qtime) real(wp), intent(in) :: qtime @@ -1355,9 +1313,7 @@ contains end subroutine s_write_lag_particles - !> Subroutine that writes some useful statistics related to the volume fraction of the particles (void fraction) in the - !! computatioational domain on each time step. - !! @param qtime Current time + !> Write void fraction statistics at each time step impure subroutine s_write_void_evol(qtime) real(wp), intent(in) :: qtime @@ -1420,8 +1376,7 @@ contains end subroutine s_write_void_evol - !> Subroutine that writes the restarting files for the particles in the lagrangian solver. - !! @param t_step Current time step + !> Write restart files for the Lagrangian bubble solver impure subroutine s_write_restart_lag_bubbles(t_step) ! Generic string used to store the address of a particular file @@ -1561,7 +1516,7 @@ contains end subroutine s_write_restart_lag_bubbles - !> This procedure calculates the maximum and minimum radius of each bubble. + !> Compute the maximum and minimum radius of each bubble subroutine s_calculate_lag_bubble_stats() integer :: k @@ -1578,7 +1533,7 @@ contains end subroutine s_calculate_lag_bubble_stats - !> Subroutine that writes the maximum and minimum radius of each bubble. + !> Write the maximum and minimum radius statistics for each bubble impure subroutine s_write_lag_bubble_stats() integer :: k @@ -1614,8 +1569,7 @@ contains end subroutine s_write_lag_bubble_stats - !> The purpose of this subroutine is to remove one specific particle if dt is too small. - !! @param bub_id Particle id + !> Remove a specific Lagrangian bubble when dt becomes too small impure subroutine s_remove_lag_bubble(bub_id) integer, intent(in) :: bub_id @@ -1650,7 +1604,7 @@ contains end subroutine s_remove_lag_bubble - !> The purpose of this subroutine is to deallocate variables + !> Finalize the Lagrangian bubble solver impure subroutine s_finalize_lagrangian_solver() integer :: i diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index ea675f904c..24eed4516d 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -12,14 +12,7 @@ module m_bubbles_EL_kernels contains - !> The purpose of this subroutine is to smear the strength of the lagrangian bubbles into the Eulerian framework using different - !! approaches. - !! @param nBubs Number of lagrangian bubbles in the current domain - !! @param lbk_rad Radius of the bubbles - !! @param lbk_vel Interface velocity of the bubbles - !! @param lbk_s Computational coordinates of the bubbles - !! @param lbk_pos Spatial coordinates of the bubbles - !! @param updatedvar Eulerian variable to be updated + !> Smear the Lagrangian bubble effects onto the Eulerian grid using the selected kernel subroutine s_smoothfunction(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) integer, intent(in) :: nBubs @@ -36,8 +29,7 @@ contains end subroutine s_smoothfunction - !> The purpose of this procedure contains the algorithm to use the delta kernel function to map the effect of the bubbles. The - !! effect of the bubbles only affects the cell where the bubble is located. + !> Apply the delta kernel function to map bubble effects onto the containing cell subroutine s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) integer, intent(in) :: nBubs @@ -88,8 +80,7 @@ contains end subroutine s_deltafunc - !> The purpose of this procedure contains the algorithm to use the gaussian kernel function to map the effect of the bubbles. - !! The effect of the bubbles affects the 3X3x3 cells that surround the bubble. + !> Apply the Gaussian kernel function to smear bubble effects onto surrounding cells subroutine s_gaussian(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) integer, intent(in) :: nBubs @@ -187,7 +178,7 @@ contains end subroutine s_gaussian - !> The purpose of this subroutine is to apply the gaussian kernel function for each bubble (Maeda and Colonius, 2018)). + !> Evaluate the Gaussian kernel at a grid node for a given bubble center subroutine s_applygaussian(center, cellaux, nodecoord, stddsv, strength_idx, func) $:GPU_ROUTINE(function_name='s_applygaussian',parallelism='[seq]', cray_inline=True) @@ -251,10 +242,7 @@ contains end subroutine s_applygaussian - !> The purpose of this subroutine is to check if the current cell is outside the computational domain or not (including ghost - !! cells). - !! @param cellaux Tested cell to smear the bubble effect in. - !! @param celloutside If true, then cellaux is outside the computational domain. + !> Check if the current cell is outside the computational domain including ghost cells subroutine s_check_celloutside(cellaux, celloutside) $:GPU_ROUTINE(function_name='s_check_celloutside',parallelism='[seq]', cray_inline=True) @@ -286,9 +274,7 @@ contains end subroutine s_check_celloutside - !> This subroutine relocates the current cell, if it intersects a symmetric boundary. - !! @param cell Cell of the current bubble - !! @param cellaux Cell to map the bubble effect in. + !> Relocate cells that intersect a symmetric boundary subroutine s_shift_cell_symmetric_bc(cellaux, cell) $:GPU_ROUTINE(function_name='s_shift_cell_symmetric_bc', parallelism='[seq]', cray_inline=True) @@ -325,9 +311,6 @@ contains end subroutine s_shift_cell_symmetric_bc !> Calculates the standard deviation of the bubble being smeared in the Eulerian framework. - !! @param cell Cell where the bubble is located - !! @param volpart Volume of the bubble - !! @param stddsv Standard deviaton subroutine s_compute_stddsv(cell, volpart, stddsv) $:GPU_ROUTINE(function_name='s_compute_stddsv',parallelism='[seq]', cray_inline=True) @@ -363,11 +346,7 @@ contains end subroutine s_compute_stddsv - !> The purpose of this procedure is to calculate the characteristic cell volume - !! @param cellx x-direction cell index - !! @param celly y-direction cell index - !! @param cellz z-direction cell index - !! @param Charvol Characteristic volume + !> Compute the characteristic cell volume subroutine s_get_char_vol(cellx, celly, cellz, Charvol) $:GPU_ROUTINE(function_name='s_get_char_vol',parallelism='[seq]', cray_inline=True) @@ -387,9 +366,7 @@ contains end subroutine s_get_char_vol - !> This subroutine transforms the computational coordinates of the bubble from real type into integer. - !! @param s_cell Computational coordinates of the bubble, real type - !! @param get_cell Computational coordinates of the bubble, integer type + !> Convert bubble computational coordinates from real to integer cell indices subroutine s_get_cell(s_cell, get_cell) $:GPU_ROUTINE(function_name='s_get_cell',parallelism='[seq]', cray_inline=True) diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 2502fb73dd..d57e013536 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -88,8 +88,7 @@ module m_cbc contains - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the CBC module impure subroutine s_initialize_cbc_module integer :: i @@ -352,8 +351,6 @@ contains end subroutine s_initialize_cbc_module !> Compute CBC coefficients - !! @param cbc_dir_in CBC coordinate direction - !! @param cbc_loc_in CBC coordinate location subroutine s_compute_cbc_coefficients(cbc_dir_in, cbc_loc_in) ! Compute grid-dependent CBC coefficients for given direction and location @@ -437,11 +434,7 @@ contains end subroutine s_compute_cbc_coefficients - !> @brief Associates finite-difference and polynomial-interpolation CBC coefficients with targets based on coordinate direction - !! and boundary location. The goal of the procedure is to associate the FD and PI coefficients, or CBC coefficients, with the - !! appropriate targets, based on the coordinate direction and location of the CBC. - !! @param cbc_dir_in CBC coordinate direction - !! @param cbc_loc_in CBC coordinate location + !> Associate CBC finite-difference and polynomial-interpolation coefficients based on direction and boundary location subroutine s_associate_cbc_coefficients_pointers(cbc_dir_in, cbc_loc_in) integer, intent(in) :: cbc_dir_in, cbc_loc_in @@ -494,17 +487,7 @@ contains end subroutine s_associate_cbc_coefficients_pointers - !> The following is the implementation of the CBC based on the work of Thompson (1987, 1990) on hyperbolic systems. The CBC is - !! indirectly applied in the computation of the right-hand-side (RHS) near the relevant domain boundary through the modification - !! of the fluxes. Characteristic boundary conditions, Thompson JCP (1987, 1990) - !! @param q_prim_vf Cell-average primitive variables - !! @param flux_vf Cell-boundary-average fluxes - !! @param flux_src_vf Cell-boundary-average flux sources - !! @param cbc_dir_norm CBC coordinate direction - !! @param cbc_loc_norm CBC coordinate location - !! @param ix Index bound in the first coordinate direction - !! @param iy Index bound in the second coordinate direction - !! @param iz Index bound in the third coordinate direction + !> Apply characteristic boundary conditions by modifying fluxes near domain boundaries subroutine s_cbc(q_prim_vf, flux_vf, flux_src_vf, cbc_dir_norm, cbc_loc_norm, ix, iy, iz) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -970,14 +953,7 @@ contains end subroutine s_cbc - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are required for the setup of the selected CBC. - !! @param q_prim_vf Cell-average primitive variables - !! @param flux_vf Cell-boundary-average fluxes - !! @param flux_src_vf Cell-boundary-average flux sources - !! @param ix Index bound in the first coordinate direction - !! @param iy Index bound in the second coordinate direction - !! @param iz Index bound in the third coordinate direction + !> Set up the selected CBC for the current boundary subroutine s_initialize_cbc(q_prim_vf, flux_vf, flux_src_vf, ix, iy, iz) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -1231,8 +1207,6 @@ contains end subroutine s_initialize_cbc !> Deallocation and/or the disassociation procedures that are necessary in order to finalize the CBC application - !! @param flux_vf Cell-boundary-average fluxes - !! @param flux_src_vf Cell-boundary-average flux sources subroutine s_finalize_cbc(flux_vf, flux_src_vf) type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf @@ -1395,7 +1369,7 @@ contains end subroutine s_finalize_cbc - !> @brief Detects whether any domain boundary uses characteristic boundary conditions. + !> Detect whether any domain boundary uses characteristic boundary conditions elemental subroutine s_any_cbc_boundaries(toggle) logical, intent(inout) :: toggle diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index c4ccecd7d8..6153b7b287 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -65,7 +65,7 @@ contains end subroutine s_check_inputs_weno - !> @brief Validates that the grid resolution is sufficient for the MUSCL reconstruction order. + !> Validate that the grid resolution is sufficient for the MUSCL reconstruction order impure subroutine s_check_inputs_muscl character(len=5) :: numStr !< for int to string conversion diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index af31d30fe9..842313b634 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -19,7 +19,7 @@ module m_compute_levelset contains - !> @brief Dispatches level-set distance and normal computations for all ghost points based on their patch geometry type. + !> Dispatch level-set distance and normal computations for all ghost points based on patch geometry type impure subroutine s_apply_levelset(gps, num_gps) type(ghost_point), dimension(:), intent(inout) :: gps @@ -72,7 +72,7 @@ contains end subroutine s_apply_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to a circular immersed boundary. + !> Compute the signed distance and outward normal from a ghost point to a circular immersed boundary subroutine s_circle_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -102,7 +102,7 @@ contains end subroutine s_circle_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to a 2D NACA airfoil surface. + !> Compute the signed distance and outward normal from a ghost point to a 2D NACA airfoil surface subroutine s_airfoil_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -181,8 +181,7 @@ contains end subroutine s_airfoil_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to a 3D extruded airfoil surface including spanwise - !! end caps. + !> Compute the signed distance and outward normal from a ghost point to a 3D extruded airfoil surface subroutine s_3d_airfoil_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -348,8 +347,7 @@ contains end subroutine s_rectangle_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to an elliptical immersed boundary via a quadratic - !! projection. + !> Compute the signed distance and outward normal from a ghost point to an elliptical immersed boundary subroutine s_ellipse_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -399,7 +397,7 @@ contains end subroutine s_ellipse_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to the nearest face of a cuboid immersed boundary. + !> Compute the signed distance and outward normal from a ghost point to a cuboid immersed boundary subroutine s_cuboid_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -486,7 +484,7 @@ contains end subroutine s_cuboid_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to a spherical immersed boundary. + !> Compute the signed distance and outward normal from a ghost point to a spherical immersed boundary subroutine s_sphere_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -522,8 +520,7 @@ contains end subroutine s_sphere_levelset - !> @brief Computes the signed distance and outward normal from a ghost point to a cylindrical immersed boundary surface and end - !! caps. + !> Compute the signed distance and outward normal from a ghost point to a cylindrical immersed boundary subroutine s_cylinder_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') @@ -598,7 +595,6 @@ contains end subroutine s_cylinder_levelset !> The STL patch is a 2/3D geometry that is imported from an STL file. - !! @param gp Ghost point to compute levelset for subroutine s_model_levelset(gp) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index de7b5259d0..296eca7a1a 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -57,12 +57,6 @@ module m_data_output contains !> Write data files. Dispatch subroutine that replaces procedure pointer. - !! @param q_cons_vf Conservative variables - !! @param q_T_sf Temperature scalar field - !! @param q_prim_vf Primitive variables - !! @param t_step Current time step - !! @param bc_type Boundary condition type - !! @param beta Eulerian void fraction from lagrangian bubbles impure subroutine s_write_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -80,9 +74,7 @@ contains end subroutine s_write_data_files - !> The purpose of this subroutine is to open a new or pre- existing run-time information file and append to it the basic header - !! information relevant to current simulation. In general, this requires generating a table header for those stability criteria - !! which will be written at every time-step. + !> Open the run-time information file and write the stability criteria table header impure subroutine s_open_run_time_information_file character(LEN=name_len), parameter :: file_name = 'run_time.inf' !< Name of the run-time information file @@ -116,7 +108,7 @@ contains end subroutine s_open_run_time_information_file - !> This opens a formatted data file where the root processor can write out the CoM information + !> Open center-of-mass data files for writing impure subroutine s_open_com_files() character(len=path_len + 3*name_len) :: file_path !< Relative path to the CoM file in the case directory @@ -141,7 +133,7 @@ contains end subroutine s_open_com_files - !> This opens a formatted data file where the root processor can write out flow probe information + !> Open flow probe data files for writing impure subroutine s_open_probe_files character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the probe data file in the case directory @@ -184,11 +176,7 @@ contains end subroutine s_open_ib_state_file - !> The goal of the procedure is to output to the run-time information file the stability criteria extrema in the entire - !! computational domain and at the given time-step. Moreover, the subroutine is also in charge of tracking these stability - !! criteria extrema over all time-steps. - !! @param q_prim_vf Cell-average primitive variables - !! @param t_step Current time step + !> Write stability criteria extrema to the run-time information file at the given time step impure subroutine s_write_run_time_information(q_prim_vf, t_step) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -303,13 +291,7 @@ contains end subroutine s_write_run_time_information - !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. - !! @param q_cons_vf Cell-average conservative variables - !! @param q_T_sf Temperature scalar field - !! @param q_prim_vf Cell-average primitive variables - !! @param t_step Current time-step - !! @param bc_type Boundary condition type - !! @param beta Eulerian void fraction from lagrangian bubbles + !> Write grid and conservative variable data files in serial format impure subroutine s_write_serial_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -665,11 +647,7 @@ contains end subroutine s_write_serial_data_files - !> The goal of this subroutine is to output the grid and conservative variables data files for given time-step. - !! @param q_cons_vf Cell-average conservative variables - !! @param t_step Current time-step - !! @param bc_type Boundary condition type - !! @param beta Eulerian void fraction from lagrangian bubbles + !> Write grid and conservative variable data files in parallel via MPI I/O impure subroutine s_write_parallel_data_files(q_cons_vf, t_step, bc_type, beta) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -865,7 +843,7 @@ contains end subroutine s_write_parallel_data_files - !> @brief Writes immersed boundary marker data to a serial (per-processor) unformatted file. + !> Write immersed boundary marker data to a serial (per-processor) unformatted file subroutine s_write_serial_ib_data(time_step) integer, intent(in) :: time_step @@ -883,7 +861,7 @@ contains end subroutine s_write_serial_ib_data - !> @brief Writes immersed boundary marker data in parallel using MPI I/O. + !> Write immersed boundary marker data in parallel using MPI I/O subroutine s_write_parallel_ib_data(time_step) integer, intent(in) :: time_step @@ -920,7 +898,7 @@ contains end subroutine s_write_parallel_ib_data - !> @brief Dispatches immersed boundary data output to the serial or parallel writer. + !> Dispatch immersed boundary data output to the serial or parallel writer subroutine s_write_ib_data_file(time_step) integer, intent(in) :: time_step @@ -933,7 +911,7 @@ contains end subroutine s_write_ib_data_file - !> @brief Writes IB state records to D/ib_state.dat. Must be called only on rank 0. + !> Write IB state records to D/ib_state.dat (rank 0 only) impure subroutine s_write_ib_state_file() integer :: i @@ -945,9 +923,7 @@ contains end subroutine s_write_ib_state_file - !> This writes a formatted data file where the root processor can write out the CoM information - !! @param t_step Current time-step - !! @param c_mass_in Center of mass information + !> Write center-of-mass data at the current time step impure subroutine s_write_com_files(t_step, c_mass_in) integer, intent(in) :: t_step @@ -980,10 +956,7 @@ contains end subroutine s_write_com_files - !> This writes a formatted data file for the flow probe information - !! @param t_step Current time-step - !! @param q_cons_vf Conservative variables - !! @param accel_mag Acceleration magnitude information + !> Write flow probe data at the current time step impure subroutine s_write_probe_files(t_step, q_cons_vf, accel_mag) integer, intent(in) :: t_step @@ -1520,9 +1493,7 @@ contains end subroutine s_write_probe_files - !> The goal of this subroutine is to write to the run-time information file basic footer information applicable to the current - !! computation and to close the file when done. The footer contains the stability criteria extrema over all of the time-steps - !! and the simulation run-time. + !> Write footer with stability criteria extrema and run-time to the information file, then close it impure subroutine s_close_run_time_information_file real(wp) :: run_time !< Run-time of the simulation @@ -1571,8 +1542,7 @@ contains end subroutine s_close_ib_state_file - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the data output module impure subroutine s_initialize_data_output_module integer :: i, m_ds, n_ds, p_ds diff --git a/src/simulation/m_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index 61477a4f9e..80149b2303 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -97,10 +97,6 @@ contains end subroutine s_initialize_derived_variables !> Writes coherent body information, communication files, and probes. - !! @param t_step Current time-step - !! @param q_cons_vf Conservative variables - !! @param q_prim_ts1 Primitive variables at time-stage 1 - !! @param q_prim_ts2 Primitive variables at time-stage 2 subroutine s_compute_derived_variables(t_step, q_cons_vf, q_prim_ts1, q_prim_ts2) integer, intent(in) :: t_step @@ -146,15 +142,7 @@ contains end subroutine s_compute_derived_variables - !> This subroutine receives as inputs the indicator of the component of the acceleration that should be outputted and the - !! primitive variables. From those inputs, it proceeds to calculate values of the desired acceleration component, which are - !! subsequently stored in derived flow quantity storage variable, q_sf. - !! @param i Acceleration component indicator - !! @param q_prim_vf0 Primitive variables - !! @param q_prim_vf1 Primitive variables - !! @param q_prim_vf2 Primitive variables - !! @param q_prim_vf3 Primitive variables - !! @param q_sf Acceleration component + !> Compute a component of the acceleration field from the primitive variables subroutine s_derive_acceleration_component(i, q_prim_vf0, q_prim_vf1, q_prim_vf2, q_prim_vf3, q_sf) integer, intent(in) :: i @@ -348,11 +336,7 @@ contains end subroutine s_derive_acceleration_component - !> This subroutine is used together with the volume fraction model and when called upon, it computes the location of of the - !! center of mass for each fluid from the inputted primitive variables, q_prim_vf. The computed location is then written to a - !! formatted data file by the root process. - !! @param q_vf Primitive variables - !! @param c_m Mass,x-location,y-location,z-location + !> Compute the center of mass for each fluid from the primitive variables impure subroutine s_derive_center_of_mass(q_vf, c_m) type(scalar_field), dimension(sys_size), intent(in) :: q_vf diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index a89e626bf6..320878159f 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -58,8 +58,7 @@ module m_fftw contains - !> The purpose of this subroutine is to create the fftw plan that will be used in the forward and backward DFTs when applying - !! the Fourier filter in the azimuthal direction. + !> Initialize the FFTW module impure subroutine s_initialize_fftw_module integer :: ierr !< Generic flag used to identify and report GPU errors @@ -116,9 +115,7 @@ contains end subroutine s_initialize_fftw_module - !> The purpose of this subroutine is to apply a Fourier low- pass filter to the flow variables in the azimuthal direction to - !! remove the high-frequency content. This alleviates the restrictive CFL condition arising from cells near the axis. - !! @param q_cons_vf Conservative variables + !> Apply a Fourier low-pass filter in the azimuthal direction to remove high-frequency content impure subroutine s_apply_fourier_filter(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -289,8 +286,7 @@ contains end subroutine s_apply_fourier_filter - !> The purpose of this subroutine is to destroy the fftw plan that will be used in the forward and backward DFTs when applying - !! the Fourier filter in the azimuthal direction. + !> Finalize the FFTW module impure subroutine s_finalize_fftw_module #if defined(MFC_GPU) diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index c3856e605f..56528b7974 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -853,8 +853,7 @@ contains end subroutine s_assign_default_values_to_user_inputs - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the global parameters module impure subroutine s_initialize_global_parameters_module integer :: i, j, k diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index d434fb1ff7..06c567d1fe 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -31,9 +31,7 @@ module m_hyperelastic contains - !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. calculate the - !! grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the FFtranspose to - !! obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space + !> Initialize the hyperelastic module impure subroutine s_initialize_hyperelastic_module integer :: i !< generic iterator @@ -73,11 +71,7 @@ contains end subroutine s_initialize_hyperelastic_module - !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf Primitive variables - !! calculate the grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the - !! FFtranspose to obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space + !> Compute the left Cauchy-Green deformation tensor and update the hyperelastic stress subroutine s_hyperelastic_rmt_stress_update(q_cons_vf, q_prim_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -195,15 +189,7 @@ contains end subroutine s_hyperelastic_rmt_stress_update - !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. - !! @param btensor_in Left Cauchy-Green deformation tensor - !! @param q_prim_vf Primitive variables - !! @param G_param Elastic shear modulus - !! @param j x-direction cell index - !! @param k y-direction cell index - !! @param l z-direction cell index - !! calculate the grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the - !! FFtranspose to obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space + !> Compute the neo-Hookean Cauchy stress from the left Cauchy-Green tensor subroutine s_neoHookean_cauchy_solver(btensor_in, q_prim_vf, G_param, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') @@ -231,15 +217,7 @@ contains end subroutine s_neoHookean_cauchy_solver - !> The following subroutine handles the calculation of the btensor. The calculation of the btensor takes qprimvf. - !! @param btensor_in Left Cauchy-Green deformation tensor - !! @param q_prim_vf Primitive variables - !! @param G_param Elastic shear modulus - !! @param j x-direction cell index - !! @param k y-direction cell index - !! @param l z-direction cell index - !! calculate the grad_xi, grad_xi is a nxn tensor calculate the inverse of grad_xi to obtain F, F is a nxn tensor calculate the - !! FFtranspose to obtain the btensor, btensor is nxn tensor btensor is symmetric, save the data space + !> Compute the Mooney-Rivlin Cauchy stress from the left Cauchy-Green tensor subroutine s_Mooney_Rivlin_cauchy_solver(btensor_in, q_prim_vf, G_param, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') @@ -268,7 +246,7 @@ contains end subroutine s_Mooney_Rivlin_cauchy_solver - !> @brief Deallocates memory for hyperelastic deformation tensor and finite-difference coefficients. + !> Finalize the hyperelastic module impure subroutine s_finalize_hyperelastic_module() integer :: i !< iterator diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index b28286bbff..f5d504d60d 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -35,7 +35,7 @@ module m_hypoelastic contains - !> @brief Allocates arrays and computes finite-difference coefficients for the hypoelastic stress model. + !> Initialize the hypoelastic module impure subroutine s_initialize_hypoelastic_module integer :: i @@ -78,10 +78,7 @@ contains end subroutine s_initialize_hypoelastic_module - !> The purpose of this procedure is to compute the source terms that are needed for the elastic stress equations - !! @param idir Dimension splitting index - !! @param q_prim_vf Primitive variables - !! @param rhs_vf rhs variables + !> Compute the hypoelastic stress source terms subroutine s_compute_hypoelastic_rhs(idir, q_prim_vf, rhs_vf) integer, intent(in) :: idir @@ -331,7 +328,7 @@ contains end subroutine s_compute_hypoelastic_rhs - !> @brief Deallocates arrays used by the hypoelastic stress module. + !> Finalize the hypoelastic module impure subroutine s_finalize_hypoelastic_module() @:DEALLOCATE(Gs_hypo) @@ -349,7 +346,7 @@ contains end subroutine s_finalize_hypoelastic_module - !> @brief Computes the continuum damage source term from the principal stress state. + !> Compute the continuum damage source term from the principal stress state subroutine s_compute_damage_state(q_cons_vf, rhs_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index d262099973..d1f41937ec 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -51,7 +51,7 @@ module m_ib_patches contains - !> @brief Applies all immersed boundary patch geometries to mark interior cells in the IB marker array. + !> Apply all immersed boundary patch geometries to mark interior cells in the IB marker array impure subroutine s_apply_ib_patches(ib_markers) type(integer_field), intent(inout) :: ib_markers @@ -112,12 +112,7 @@ contains end subroutine s_apply_ib_patches - !> The circular patch is a 2D geometry that may be used, for example, in creating a bubble or a droplet. The geometry of the - !! patch is well-defined when its centroid and radius are provided. Note that the circular patch DOES allow for the smoothing of - !! its boundary. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !> Mark cells inside a circular immersed boundary subroutine s_ib_circle(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id @@ -159,9 +154,7 @@ contains end subroutine s_ib_circle - !> @brief Marks cells inside a 2D NACA 4-digit airfoil immersed boundary using upper and lower surface grids. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids + !> Mark cells inside a 2D NACA 4-digit airfoil immersed boundary subroutine s_ib_airfoil(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id @@ -320,10 +313,7 @@ contains end subroutine s_ib_airfoil - !> @brief Marks cells inside a 3D extruded NACA 4-digit airfoil immersed boundary with finite span. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !> Mark cells inside a 3D extruded NACA 4-digit airfoil immersed boundary with finite span subroutine s_ib_3D_airfoil(patch_id, ib_markers, xp, yp, zp) integer, intent(in) :: patch_id @@ -482,13 +472,7 @@ contains end subroutine s_ib_3D_airfoil - !> The rectangular patch is a 2D geometry that may be used, for example, in creating a solid boundary, or pre-/post- shock - !! region, in alignment with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its - !! centroid and lengths in the x- and y- coordinate directions are provided. Please note that the rectangular patch DOES NOT - !! allow for the smoothing of its boundaries. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !> Mark cells inside a rectangular immersed boundary subroutine s_ib_rectangle(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id @@ -541,12 +525,7 @@ contains end subroutine s_ib_rectangle - !> The spherical patch is a 3D geometry that may be used, for example, in creating a bubble or a droplet. The patch geometry is - !! well-defined when its centroid and radius are provided. Please note that the spherical patch DOES allow for the smoothing of - !! its boundary. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !> Mark cells inside a spherical immersed boundary subroutine s_ib_sphere(patch_id, ib_markers, xp, yp, zp) integer, intent(in) :: patch_id @@ -606,12 +585,7 @@ contains end subroutine s_ib_sphere - !> The cuboidal patch is a 3D geometry that may be used, for example, in creating a solid boundary, or pre-/post-shock region, - !! which is aligned with the axes of the Cartesian coordinate system. The geometry of such a patch is well- defined when its - !! centroid and lengths in the x-, y- and z-coordinate directions are provided. Please notice that the cuboidal patch DOES NOT - !! allow for the smearing of its boundaries. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids + !> Mark cells inside a cuboidal immersed boundary subroutine s_ib_cuboid(patch_id, ib_markers, xp, yp, zp) integer, intent(in) :: patch_id @@ -679,13 +653,7 @@ contains end subroutine s_ib_cuboid - !> The cylindrical patch is a 3D geometry that may be used, for example, in setting up a cylindrical solid boundary confinement, - !! like a blood vessel. The geometry of this patch is well-defined when the centroid, the radius and the length along the - !! cylinder's axis, parallel to the x-, y- or z-coordinate direction, are provided. Please note that the cylindrical patch DOES - !! allow for the smoothing of its lateral boundary. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids - !! @param ib True if this patch is an immersed boundary + !> Mark cells inside a cylindrical immersed boundary subroutine s_ib_cylinder(patch_id, ib_markers, xp, yp, zp) integer, intent(in) :: patch_id @@ -756,7 +724,7 @@ contains end subroutine s_ib_cylinder - !> @brief Marks cells inside a 2D elliptical immersed boundary defined by semi-axis lengths and rotation. + !> Mark cells inside a 2D elliptical immersed boundary subroutine s_ib_ellipse(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id @@ -809,8 +777,6 @@ contains end subroutine s_ib_ellipse !> The STL patch is a 2D geometry that is imported from an STL file. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids subroutine s_ib_model(patch_id, ib_markers, xp, yp) integer, intent(in) :: patch_id @@ -888,8 +854,6 @@ contains end subroutine s_ib_model !> The STL patch is a 3D geometry that is imported from an STL file. - !! @param patch_id is the patch identifier - !! @param ib_markers Array to track patch ids subroutine s_ib_3d_model(patch_id, ib_markers, xp, yp, zp) integer, intent(in) :: patch_id @@ -976,7 +940,7 @@ contains end subroutine s_ib_3d_model - !> Subroutine that computes a rotation matrix for converting to the rotating frame of the boundary + !> Compute a rotation matrix for converting to the rotating frame of the boundary subroutine s_update_ib_rotation_matrix(patch_id) integer, intent(in) :: patch_id @@ -1022,7 +986,7 @@ contains end subroutine s_update_ib_rotation_matrix - !> @brief Converts cylindrical (r, theta) coordinates to Cartesian (y, z) and stores in module variables. + !> Convert cylindrical (r, theta) coordinates to Cartesian (y, z) subroutine s_convert_cylindrical_to_cartesian_coord(cyl_y, cyl_z) $:GPU_ROUTINE(parallelism='[seq]') @@ -1034,7 +998,7 @@ contains end subroutine s_convert_cylindrical_to_cartesian_coord - !> @brief Converts a 3D cylindrical coordinate vector (x, r, theta) to Cartesian (x, y, z). + !> Convert a 3D cylindrical coordinate vector (x, r, theta) to Cartesian (x, y, z) pure function f_convert_cyl_to_cart(cyl) result(cart) $:GPU_ROUTINE(parallelism='[seq]') @@ -1046,7 +1010,7 @@ contains end function f_convert_cyl_to_cart - !> @brief Converts cylindrical coordinates (x, r) to the spherical azimuthal angle phi and stores in a module variable. + !> Convert cylindrical coordinates (x, r) to the spherical azimuthal angle phi subroutine s_convert_cylindrical_to_spherical_coord(cyl_x, cyl_y) $:GPU_ROUTINE(parallelism='[seq]') @@ -1096,7 +1060,7 @@ contains end subroutine get_bounding_indices - !> @brief encodes the patch id with a unique offset that contains information on how the IB marker wraps periodically + !> Encode the patch ID with a unique offset containing periodicity information subroutine s_encode_patch_periodicity(patch_id, x_periodicity, y_periodicity, z_periodicity, encoded_patch_id) integer, intent(in) :: patch_id, x_periodicity, y_periodicity, z_periodicity @@ -1114,7 +1078,7 @@ contains end subroutine s_encode_patch_periodicity - !> @brief decodes the encoded id to get out the original id and the way in which it is periodic + !> Decode the encoded ID to recover the original patch ID and periodicity subroutine s_decode_patch_periodicity(encoded_patch_id, patch_id, x_periodicity, y_periodicity, z_periodicity) $:GPU_ROUTINE(parallelism='[seq]') @@ -1140,7 +1104,7 @@ contains end subroutine s_decode_patch_periodicity - !> @brief Determines if we should wrap periodically + !> Determine the periodic wrapping bounds in each direction subroutine s_get_periodicities(xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper) integer, intent(out) :: xp_lower, xp_upper, yp_lower, yp_upper @@ -1175,9 +1139,6 @@ contains end subroutine s_get_periodicities !> Archimedes spiral function - !! @param myth Angle - !! @param offset Thickness - !! @param a Starting position pure elemental function f_r(myth, offset, a) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 0f5e3e9bd4..88294c7917 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -122,9 +122,7 @@ contains end subroutine s_ibm_setup - !> Subroutine that updates the conservative variables at the ghost points - !! @param pb_in Internal bubble pressure - !! @param mv_in Mass of vapor in bubble + !> Update the conservative variables at the ghost points subroutine s_ibm_correct_state(q_cons_vf, q_prim_vf, pb_in, mv_in) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Primitive Variables @@ -373,8 +371,7 @@ contains end subroutine s_ibm_correct_state - !> Function that computes the image points for each ghost point - !! @param ghost_points_in Ghost Points + !> Compute the image points for each ghost point impure subroutine s_compute_image_points(ghost_points_in) type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in @@ -483,7 +480,7 @@ contains end subroutine s_compute_image_points - !> Subroutine that finds the number of ghost points, used for allocating memory. + !> Count the number of ghost points for memory allocation subroutine s_find_num_ghost_points(num_gps_out) integer, intent(out) :: num_gps_out @@ -528,7 +525,7 @@ contains end subroutine s_find_num_ghost_points - !> Function that finds the ghost points + !> Locate all ghost points in the domain subroutine s_find_ghost_points(ghost_points_in) type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in @@ -613,7 +610,7 @@ contains end subroutine s_find_ghost_points - !> Function that computes the interpolation coefficients of image points + !> Compute the interpolation coefficients for image points subroutine s_compute_interpolation_coeffs(ghost_points_in) type(ghost_point), dimension(num_gps), intent(inout) :: ghost_points_in @@ -719,25 +716,7 @@ contains end subroutine s_compute_interpolation_coeffs - !> Function that uses the interpolation coefficients and the current state at the cell centers in order to estimate the state at - !! the image point - !! @param gp Ghost point data structure - !> @brief Interpolates primitive variables from the fluid domain to a ghost point's image point using bilinear or trilinear - !! interpolation. - !! @param alpha_rho_IP Partial density at image point - !! @param alpha_IP Volume fraction at image point - !! @param pres_IP Pressure at image point - !! @param vel_IP Velocity at image point - !! @param c_IP Speed of sound at image point - !! @param r_IP Bubble radius at image point - !! @param v_IP Bubble radial velocity at image point - !! @param pb_IP Bubble pressure at image point - !! @param mv_IP Bubble vapor mass at image point - !! @param nmom_IP Bubble moment at image point - !! @param pb_in Internal bubble pressure array - !! @param mv_in Mass of vapor in bubble array - !! @param presb_IP Bubble node pressure at image point - !! @param massv_IP Bubble node vapor mass at image point + !> Interpolate primitive variables to a ghost point's image point using bilinear or trilinear interpolation subroutine s_interpolate_image_point(q_prim_vf, gp, alpha_rho_IP, alpha_IP, pres_IP, vel_IP, c_IP, r_IP, v_IP, pb_IP, mv_IP, & & nmom_IP, pb_in, mv_in, presb_IP, massv_IP) @@ -901,7 +880,7 @@ contains end subroutine s_update_mib - !> @brief Computes pressure and viscous forces and torques on immersed bodies via a volume integration method. + !> Compute pressure and viscous forces and torques on immersed bodies via volume integration subroutine s_compute_ib_forces(q_prim_vf, fluid_pp) type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf @@ -1053,7 +1032,7 @@ contains end subroutine s_compute_ib_forces - !> Subroutine to deallocate memory reserved for the IBM module + !> Finalize the IBM module impure subroutine s_finalize_ibm_module() @:DEALLOCATE(ib_markers%sf) @@ -1122,7 +1101,6 @@ contains end subroutine s_compute_centroid_offset !> Computes the moment of inertia for an immersed boundary - !! @param ib_marker Immersed boundary marker index subroutine s_compute_moment_of_inertia(ib_marker, axis) real(wp), dimension(3), intent(in) :: axis !< the axis about which we compute the moment. Only required in 3D. @@ -1200,7 +1178,7 @@ contains end subroutine s_compute_moment_of_inertia - !> @brief Checks for periodic boundary conditions in all directions, and if so, moves patch location if it left the domain + !> Wrap immersed boundary positions across periodic domain boundaries subroutine s_wrap_periodic_ibs() integer :: patch_id @@ -1240,7 +1218,7 @@ contains end subroutine s_wrap_periodic_ibs - !> @brief Computes the cross product c = a x b of two 3D vectors. + !> Compute the cross product c = a x b of two 3D vectors subroutine s_cross_product(a, b, c) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index 562c2b9baf..7ce218829c 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -84,8 +84,7 @@ module m_igr contains - !> @brief Allocates and initializes arrays, coefficients, and GPU data structures for the implicit gradient reconstruction - !! module. + !> Initialize the IGR module subroutine s_initialize_igr_module() if (viscous) then @@ -207,7 +206,7 @@ contains end subroutine s_initialize_igr_module - !> @brief Iteratively solves the implicit gradient reconstruction system using Jacobi or Gauss-Seidel relaxation. + !> Iteratively solve the implicit gradient reconstruction system subroutine s_igr_iterative_solve(q_cons_vf, bc_type, t_step) #ifdef _CRAYFTN @@ -308,7 +307,7 @@ contains end subroutine s_igr_iterative_solve - !> @brief Computes the IGR viscous stress contribution in the x-direction and accumulates it into the RHS. + !> Compute the IGR viscous stress contribution in the x-direction and accumulate into the RHS subroutine s_igr_sigma_x(q_cons_vf, rhs_vf) #ifdef _CRAYFTN @@ -388,7 +387,7 @@ contains end subroutine s_igr_sigma_x - !> @brief Evaluates the approximate Riemann solver for the IGR scheme along a given coordinate direction. + !> Evaluate the approximate Riemann solver for the IGR scheme along a given direction subroutine s_igr_riemann_solver(q_cons_vf, rhs_vf, idir) #ifdef _CRAYFTN @@ -2614,7 +2613,7 @@ contains end subroutine s_igr_riemann_solver - !> @brief Computes pressure and maximum wavespeed from left and right reconstructed states for the IGR Riemann solver. + !> Compute pressure and maximum wavespeed from left and right reconstructed states subroutine s_get_derived_states(E_L, gamma_L, pi_inf_L, rho_L, vel_L, E_R, gamma_R, pi_inf_R, rho_R, vel_R, pres_L, pres_R, cfl) $:GPU_ROUTINE(parallelism='[seq]') @@ -2658,7 +2657,7 @@ contains end subroutine s_get_derived_states - !> @brief Accumulates the IGR numerical flux divergence into the right-hand side along the specified coordinate direction. + !> Accumulate the IGR numerical flux divergence into the RHS along the specified direction subroutine s_igr_flux_add(q_cons_vf, rhs_vf, flux_vf, idir) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, flux_vf, rhs_vf @@ -2706,7 +2705,7 @@ contains end subroutine s_igr_flux_add - !> @brief Deallocates all arrays and GPU resources allocated by the IGR module. + !> Finalize the IGR module subroutine s_finalize_igr_module() if (viscous) then diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index 4502afd92e..0c5780f995 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -33,7 +33,7 @@ module m_mpi_proxy contains - !> @brief Allocates immersed boundary communication buffers for MPI halo exchanges. + !> Initialize the MPI proxy module subroutine s_initialize_mpi_proxy_module() #ifdef MFC_MPI @@ -241,7 +241,7 @@ contains end subroutine s_mpi_bcast_user_inputs - !> @brief Broadcasts random phase numbers from rank 0 to all MPI processes. + !> Broadcast random phase numbers from rank 0 to all MPI processes impure subroutine s_mpi_send_random_number(phi_rn, num_freq) integer, intent(in) :: num_freq @@ -255,7 +255,7 @@ contains end subroutine s_mpi_send_random_number - !> @brief Deallocates immersed boundary MPI communication buffers. + !> Finalize the MPI proxy module subroutine s_finalize_mpi_proxy_module() #ifdef MFC_MPI diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index fc3d17a7c6..7dc51afaf3 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -89,7 +89,7 @@ contains end subroutine s_initialize_muscl_module - !> @brief Performs MUSCL reconstruction of left and right cell-boundary values from cell-averaged variables. + !> Perform MUSCL reconstruction of left and right cell-boundary values from cell-averaged variables subroutine s_muscl(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, is1_muscl_d, & & is2_muscl_d, is3_muscl_d) @@ -216,7 +216,7 @@ contains end subroutine s_muscl - !> @brief Applies THINC interface-compression to sharpen volume-fraction reconstructions at material interfaces. + !> Apply THINC interface-compression to sharpen volume-fraction reconstructions at material interfaces subroutine s_interface_compression(vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, muscl_dir, & & is1_muscl_d, is2_muscl_d, is3_muscl_d) @@ -286,7 +286,7 @@ contains end subroutine s_interface_compression - !> @brief Reshapes cell-averaged variable data into direction-local work arrays for MUSCL reconstruction. + !> Reshape cell-averaged variable data into direction-local work arrays for MUSCL reconstruction subroutine s_initialize_muscl(v_vf, muscl_dir) type(scalar_field), dimension(:), intent(in) :: v_vf @@ -346,7 +346,7 @@ contains end subroutine s_initialize_muscl - !> @brief Deallocates the MUSCL direction-local work arrays. + !> Finalize the MUSCL module subroutine s_finalize_muscl_module() @:DEALLOCATE(v_rs_ws_x_muscl) diff --git a/src/simulation/m_pressure_relaxation.fpp b/src/simulation/m_pressure_relaxation.fpp index 26f02c411a..45fa44287e 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -48,7 +48,6 @@ contains end subroutine s_finalize_pressure_relaxation_module !> The main pressure relaxation procedure - !! @param q_cons_vf Cell-average conservative variables subroutine s_pressure_relaxation_procedure(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index c78d6a056d..5029b6854c 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -38,7 +38,7 @@ module m_qbmm contains - !> @brief Allocates and initializes moment coefficient arrays for the QBMM module. + !> Initialize the QBMM module impure subroutine s_initialize_qbmm_module integer :: i1, i2, q, i, j @@ -400,7 +400,7 @@ contains end subroutine s_initialize_qbmm_module - !> @brief Computes the QBMM right-hand side source terms for bubble moment transport equations. + !> Compute the QBMM right-hand side source terms for bubble moment transport equations subroutine s_compute_qbmm_rhs(idir, q_cons_vf, q_prim_vf, rhs_vf, flux_n_vf, pb, rhs_pb) integer, intent(in) :: idir @@ -586,7 +586,7 @@ contains end subroutine s_compute_qbmm_rhs - !> @brief Builds the coefficient array for the non-polytropic bubble model. + !> Build the coefficient array for the non-polytropic bubble model subroutine s_coeff_nonpoly(pres, rho, c, coeffs) $:GPU_ROUTINE(function_name='s_coeff_nonpoly',parallelism='[seq]', cray_inline=True) @@ -665,7 +665,7 @@ contains end subroutine s_coeff_nonpoly - !> @brief Builds the coefficient array for the polytropic bubble model. + !> Build the coefficient array for the polytropic bubble model subroutine s_coeff(pres, rho, c, coeffs) $:GPU_ROUTINE(function_name='s_coeff',parallelism='[seq]', cray_inline=True) @@ -734,7 +734,7 @@ contains end subroutine s_coeff - !> @brief Performs moment inversion to recover quadrature weights and abscissas and evaluates bubble source terms. + !> Perform moment inversion to recover quadrature weights and abscissas and evaluate bubble source terms subroutine s_mom_inv(q_cons_vf, q_prim_vf, momsp, moms3d, pb, rhs_pb, mv, rhs_mv, ix, iy, iz) type(scalar_field), dimension(:), intent(inout) :: q_cons_vf, q_prim_vf @@ -930,7 +930,7 @@ contains $:END_GPU_PARALLEL_LOOP() contains - !> @brief Selects the polytropic or non-polytropic coefficient routine. + !> Select the polytropic or non-polytropic coefficient routine subroutine s_coeff_selector(pres, rho, c, coeff, polytropic) $:GPU_ROUTINE(function_name='s_coeff_selector',parallelism='[seq]', cray_inline=True) @@ -949,7 +949,7 @@ contains end subroutine s_coeff_selector - !> @brief Performs conditional hyperbolic QMOM (CHyQMOM) inversion for bivariate moments. + !> Perform CHyQMOM inversion for bivariate moments subroutine s_chyqmom(momin, wght, abscX, abscY) $:GPU_ROUTINE(function_name='s_chyqmom',parallelism='[seq]', cray_inline=True) @@ -1008,7 +1008,7 @@ contains end subroutine s_chyqmom - !> @brief Performs hyperbolic QMOM (HyQMOM) inversion for univariate moments. + !> Perform HyQMOM inversion for univariate moments subroutine s_hyqmom(frho, fup, fmom) $:GPU_ROUTINE(function_name='s_hyqmom',parallelism='[seq]', cray_inline=True) @@ -1028,7 +1028,7 @@ contains end subroutine s_hyqmom - !> @brief Evaluates a weighted quadrature sum over all bubble size bins and nodes. + !> Evaluate a weighted quadrature sum over all bubble size bins and nodes function f_quad(abscX, abscY, wght_in, q, r, s) $:GPU_ROUTINE(parallelism='[seq]') @@ -1054,7 +1054,7 @@ contains end function f_quad - !> @brief Evaluates a weighted 2D quadrature sum over quadrature nodes for a single size bin. + !> Evaluate a weighted 2D quadrature sum over quadrature nodes for a single size bin function f_quad2D(abscX, abscY, wght_in, pow) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 938c9809f5..46461b440a 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -133,8 +133,7 @@ module m_rhs contains - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the RHS module impure subroutine s_initialize_rhs_module integer :: i, j, k, l, id !< Generic loop iterators @@ -538,7 +537,7 @@ contains end subroutine s_initialize_rhs_module - !> @brief Computes the right-hand side of the semi-discrete governing equations for a single time stage. + !> Compute the right-hand side of the semi-discrete governing equations for a single time stage impure subroutine s_compute_rhs(q_cons_vf, q_T_sf, q_prim_vf, bc_type, rhs_vf, pb_in, rhs_pb, mv_in, rhs_mv, t_step, & & time_avg, stage) @@ -905,7 +904,7 @@ contains end subroutine s_compute_rhs - !> @brief Accumulates advection source contributions from a given coordinate direction into the RHS. + !> Accumulate advection source contributions from a given coordinate direction into the RHS subroutine s_compute_advection_source_term(idir, rhs_vf, q_cons_vf, q_prim_vf, flux_src_n_vf) integer, intent(in) :: idir @@ -1138,7 +1137,7 @@ contains contains - !> @brief Adds the advection source flux-difference terms for a single coordinate direction to the RHS. + !> Add the advection source flux-difference terms for a single coordinate direction to the RHS subroutine s_add_directional_advection_source_terms(current_idir, rhs_vf_arg, q_cons_vf_arg, q_prim_vf_arg, & & flux_src_n_vf_arg, Kterm_arg) @@ -1377,7 +1376,7 @@ contains end subroutine s_compute_advection_source_term - !> @brief Adds viscous, surface-tension, and species-diffusion source flux contributions to the RHS for a given direction. + !> Add viscous, surface-tension, and species-diffusion source flux contributions to the RHS for a given direction subroutine s_compute_additional_physics_rhs(idir, q_prim_vf, rhs_vf, flux_src_n_in, dq_prim_dx_vf, dq_prim_dy_vf, dq_prim_dz_vf) integer, intent(in) :: idir @@ -1627,16 +1626,7 @@ contains end subroutine s_compute_additional_physics_rhs - !> The purpose of this subroutine is to WENO-reconstruct the left and the right cell-boundary values, including values at the - !! Gaussian quadrature points, from the cell-averaged variables. - !! @param v_vf Cell-average variables - !! @param vL_x Left reconstructed cell-boundary values in x - !! @param vL_y Left reconstructed cell-boundary values in y - !! @param vL_z Left reconstructed cell-boundary values in z - !! @param vR_x Right reconstructed cell-boundary values in x - !! @param vR_y Right reconstructed cell-boundary values in y - !! @param vR_z Right reconstructed cell-boundary values in z - !! @param norm_dir Splitting coordinate direction + !> Reconstruct left and right cell-boundary values from cell-averaged variables subroutine s_reconstruct_cell_boundary_values(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf @@ -1682,7 +1672,7 @@ contains end subroutine s_reconstruct_cell_boundary_values - !> @brief Performs first-order (piecewise constant) reconstruction of left and right cell-boundary values. + !> Perform first-order (piecewise constant) reconstruction of left and right cell-boundary values subroutine s_reconstruct_cell_boundary_values_first_order(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 492547e77d..c08264c153 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -85,28 +85,6 @@ contains !> Dispatch to the subroutines that are utilized to compute the Riemann problem solution. For additional information please !! reference: 1) s_hll_riemann_solver 2) s_hllc_riemann_solver 3) s_exact_riemann_solver 4) s_hlld_riemann_solver - !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) - !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) - !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the cell-average primitive variables - !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) - !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) - !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the cell-average primitive variables - !! @param q_prim_vf Cell-averaged primitive variables - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & & qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & @@ -1704,28 +1682,6 @@ contains end subroutine s_lf_riemann_solver ! HLLC Riemann solver with contact restoration, Toro et al. Shock Waves (1994) - !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) - !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) - !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the cell-average primitive variables - !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) - !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) - !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the cell-average primitive variables - !! @param q_prim_vf Cell-averaged primitive variables - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & @@ -3590,8 +3546,7 @@ contains end subroutine s_hlld_riemann_solver - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the Riemann solvers module impure subroutine s_initialize_riemann_solvers_module ! Allocating the variables that will be utilized to formulate the left, right, and average states of the Riemann problem, as @@ -3673,24 +3628,7 @@ contains end subroutine s_initialize_riemann_solvers_module - !> The purpose of this subroutine is to populate the buffers of the left and right Riemann states variables, depending on the - !! boundary conditions. - !! @param qL_prim_rsx_vf Left WENO-reconstructed cell-boundary values (x-dir) - !! @param qL_prim_rsy_vf Left WENO-reconstructed cell-boundary values (y-dir) - !! @param qL_prim_rsz_vf Left WENO-reconstructed cell-boundary values (z-dir) - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives - !! @param qR_prim_rsx_vf Right WENO-reconstructed cell-boundary values (x-dir) - !! @param qR_prim_rsy_vf Right WENO-reconstructed cell-boundary values (y-dir) - !! @param qR_prim_rsz_vf Right WENO-reconstructed cell-boundary values (z-dir) - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the first-order z-dir spatial derivatives - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir + !> Populate the left and right Riemann state variable buffers based on boundary conditions subroutine s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & @@ -4024,10 +3962,7 @@ contains end subroutine s_populate_riemann_states_variables_buffers - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures needed to configure the chosen Riemann solver algorithm. - !! @param flux_src_vf Intra-cell fluxes sources - !! @param norm_dir Dir. splitting direction + !> 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 @@ -4176,22 +4111,7 @@ contains end subroutine s_initialize_riemann_solver - !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. Calculates Cartesian components of the - !! stress tensor using averaged velocity derivatives and cylindrical geometric factors, then updates `flux_src_vf`. Assumes - !! x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). - !! @param[in] velL_vf Left boundary velocity (\f$v_x, v_y, v_z\f$) (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary \f$\partial v_i/\partial x\f$ (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary \f$\partial v_i/\partial y\f$ (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary \f$\partial v_i/\partial z\f$ (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity (\f$v_x, v_y, v_z\f$) (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary \f$\partial v_i/\partial x\f$ (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary \f$\partial v_i/\partial y\f$ (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary \f$\partial v_i/\partial z\f$ (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x-face, 2=y-face, 3=z-face). - !! @param[in] ix Global X-direction loop bounds (int_bounds_info). - !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). + !> 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, norm_dir, ix, iy, iz) @@ -4365,16 +4285,7 @@ contains end subroutine s_compute_cylindrical_viscous_source_flux - !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. Calculates averaged velocity gradients, - !! gets Re and interface velocities, calls helpers for shear/bulk stress, then updates `flux_src_vf`. - !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). + !> 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, norm_dir) @@ -4498,11 +4409,7 @@ contains end subroutine s_compute_cartesian_viscous_source_flux - !> @brief Calculates shear stress tensor components. tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear - !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). - !! @param[in] Re_shear Shear Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). + !> 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]') @@ -4534,10 +4441,7 @@ contains end subroutine s_calculate_shear_stress_tensor - !> @brief Calculates bulk stress tensor components (diagonal only). tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. - !! @param[in] Re_bulk Bulk Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). + !> Compute bulk stress tensor components (diagonal only) subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) $:GPU_ROUTINE(parallelism='[seq]') @@ -4562,10 +4466,6 @@ contains end subroutine s_calculate_bulk_stress_tensor !> Deallocation and/or disassociation procedures that are needed to finalize the selected Riemann problem solver - !! @param flux_vf Intercell fluxes - !! @param flux_src_vf Intercell source fluxes - !! @param flux_gsrc_vf Intercell geometric source fluxes - !! @param norm_dir Dimensional splitting coordinate direction 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 diff --git a/src/simulation/m_sim_helpers.fpp b/src/simulation/m_sim_helpers.fpp index 2688e42b1c..2a4a4133c1 100644 --- a/src/simulation/m_sim_helpers.fpp +++ b/src/simulation/m_sim_helpers.fpp @@ -19,9 +19,6 @@ module m_sim_helpers contains !> Computes the modified dtheta for Fourier filtering in azimuthal direction - !! @param k y coordinate index - !! @param l z coordinate index - !! @return fltr_dtheta Modified dtheta value for cylindrical coordinates function f_compute_filtered_dtheta(k, l) result(fltr_dtheta) $:GPU_ROUTINE(parallelism='[seq]') @@ -45,12 +42,6 @@ contains end function f_compute_filtered_dtheta !> Computes inviscid CFL terms for multi-dimensional cases (2D/3D only) - !! @param vel directional velocities - !! @param c mixture speed of sound - !! @param j x coordinate index - !! @param k y coordinate index - !! @param l z coordinate index - !! @return cfl_terms computed CFL terms for 2D/3D cases function f_compute_multidim_cfl_terms(vel, c, j, k, l) result(cfl_terms) $:GPU_ROUTINE(parallelism='[seq]') @@ -79,20 +70,6 @@ contains end function f_compute_multidim_cfl_terms !> Computes enthalpy - !! @param q_prim_vf cell centered primitive variables - !! @param pres mixture pressure - !! @param rho mixture density - !! @param gamma mixture gamma - !! @param pi_inf mixture pi_inf - !! @param Re mixture reynolds number - !! @param H mixture enthalpy - !! @param alpha component alphas - !! @param vel directional velocities - !! @param vel_sum squard sum of velocity components - !! @param qv Fluid reference energy - !! @param j x index - !! @param k y index - !! @param l z index subroutine s_compute_enthalpy(q_prim_vf, pres, rho, gamma, pi_inf, Re, H, alpha, vel, vel_sum, qv, j, k, l) $:GPU_ROUTINE(function_name='s_compute_enthalpy',parallelism='[seq]', cray_inline=True) @@ -161,16 +138,6 @@ contains end subroutine s_compute_enthalpy !> Computes stability criterion for a specified dt - !! @param vel directional velocities - !! @param c mixture speed of sound - !! @param rho Density - !! @param Re_l mixture Reynolds number - !! @param j x index - !! @param k y index - !! @param l z index - !! @param icfl_sf cell-centered inviscid cfl number - !! @param vcfl_sf (optional) cell-centered viscous CFL number - !! @param Rc_sf (optional) cell centered Rc subroutine s_compute_stability_from_dt(vel, c, rho, Re_l, j, k, l, icfl_sf, vcfl_sf, Rc_sf) $:GPU_ROUTINE(parallelism='[seq]') @@ -221,14 +188,6 @@ contains end subroutine s_compute_stability_from_dt !> Computes dt for a specified CFL number - !! @param vel directional velocities - !! @param c Speed of sound - !! @param max_dt cell centered maximum dt - !! @param rho cell centered density - !! @param Re_l cell centered Reynolds number - !! @param j x coordinate - !! @param k y coordinate - !! @param l z coordinate subroutine s_compute_dt_from_cfl(vel, c, max_dt, rho, Re_l, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 9f752c17c3..49fb11c26d 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -59,7 +59,6 @@ module m_start_up contains !> Read data files. Dispatch subroutine that replaces procedure pointer. - !! @param q_cons_vf Conservative variables impure subroutine s_read_data_files(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -72,8 +71,7 @@ contains end subroutine s_read_data_files - !> The purpose of this procedure is to first verify that an input file has been made available by the user. Provided that this - !! is so, the input file is then read in. + !> Verify the input file exists and read it impure subroutine s_read_input_file character(LEN=name_len), parameter :: file_path = './simulation.inp' @@ -150,8 +148,7 @@ contains end subroutine s_read_input_file - !> The goal of this procedure is to verify that each of the user provided inputs is valid and that their combination constitutes - !! a meaningful configuration for the simulation. + !> Validate that all user-provided inputs form a consistent simulation configuration impure subroutine s_check_input_file character(LEN=path_len) :: file_path @@ -170,8 +167,7 @@ contains end subroutine s_check_input_file - !> @brief Reads serial initial condition and grid data files and computes cell-width distributions. - !! @param q_cons_vf Cell-averaged conservative variables + !> Read serial initial condition and grid data files and compute cell-width distributions impure subroutine s_read_serial_data_files(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -297,8 +293,7 @@ contains end subroutine s_read_serial_data_files - !> @brief Reads parallel initial condition and grid data files via MPI I/O. - !! @param q_cons_vf Conservative variables + !> Read parallel initial condition and grid data files via MPI I/O impure subroutine s_read_parallel_data_files(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf @@ -554,9 +549,7 @@ contains end subroutine s_read_parallel_data_files - !> The purpose of this procedure is to initialize the values of the internal-energy equations of each phase from the mass of - !! each phase, the mixture momentum and mixture-total-energy equations. - !! @param v_vf conservative variables + !> Initialize internal-energy equations from phase mass, mixture momentum, and total energy subroutine s_initialize_internal_energy_equations(v_vf) type(scalar_field), dimension(sys_size), intent(inout) :: v_vf @@ -613,7 +606,7 @@ contains end subroutine s_initialize_internal_energy_equations - !> @brief Advances the simulation by one time step, handling CFL-based dt and time-stepper dispatch. + !> Advance the simulation by one time step, handling CFL-based dt and time-stepper dispatch impure subroutine s_perform_time_step(t_step, time_avg) integer, intent(inout) :: t_step @@ -679,7 +672,7 @@ contains end subroutine s_perform_time_step - !> @brief Collects per-process wall-clock times and writes aggregate performance metrics to file. + !> Collect per-process wall-clock times and write aggregate performance metrics to file impure subroutine s_save_performance_metrics(time_avg, time_final, io_time_avg, io_time_final, proc_time, io_proc_time, & & file_exists) @@ -740,7 +733,7 @@ contains end subroutine s_save_performance_metrics - !> @brief Saves conservative variable data to disk at the current time step. + !> Save conservative variable data to disk at the current time step impure subroutine s_save_data(t_step, start, finish, io_time_avg, nt) integer, intent(inout) :: t_step @@ -834,7 +827,7 @@ contains end subroutine s_save_data - !> @brief Initializes all simulation sub-modules in the required dependency order. + !> Initialize all simulation sub-modules in the required dependency order impure subroutine s_initialize_modules integer :: m_ds, n_ds, p_ds @@ -945,7 +938,7 @@ contains end subroutine s_initialize_modules - !> @brief Sets up the MPI execution environment, binds GPUs, and decomposes the computational domain. + !> Set up the MPI execution environment, bind GPUs, and decompose the computational domain impure subroutine s_initialize_mpi_domain integer :: ierr @@ -1015,7 +1008,7 @@ contains end subroutine s_initialize_mpi_domain - !> @brief Transfers initial conservative variable and model parameter data to the GPU device. + !> Transfer initial conservative variable and model parameter data to the GPU device subroutine s_initialize_gpu_vars integer :: i @@ -1085,7 +1078,7 @@ contains end subroutine s_initialize_gpu_vars - !> @brief Finalizes and deallocates all simulation sub-modules in reverse initialization order. + !> Finalize and deallocate all simulation sub-modules in reverse initialization order impure subroutine s_finalize_modules call s_finalize_time_steppers_module() diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index a8525630b2..b5af98d8fa 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -66,7 +66,7 @@ contains end subroutine s_initialize_surface_tension_module - !> @brief Computes the capillary (surface-tension) source flux from reconstructed color-gradient fields. + !> Compute the capillary source flux from reconstructed color-gradient fields subroutine s_compute_capillary_source_flux(vSrc_rsx_vf, vSrc_rsy_vf, vSrc_rsz_vf, flux_src_vf, id, isx, isy, isz) real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsx_vf @@ -214,7 +214,7 @@ contains end subroutine s_compute_capillary_source_flux - !> @brief Computes color-function gradients and their norms, then reconstructs them at cell boundaries. + !> Compute color-function gradients and reconstruct them at cell boundaries impure subroutine s_get_capillary(q_prim_vf, bc_type) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -291,7 +291,7 @@ contains end subroutine s_get_capillary - !> @brief Reconstructs left and right cell-boundary values of capillary (color-gradient) variables using WENO or MUSCL. + !> Reconstruct left and right cell-boundary values of capillary variables subroutine s_reconstruct_cell_boundary_values_capillary(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf @@ -366,7 +366,7 @@ contains end subroutine s_reconstruct_cell_boundary_values_capillary - !> @brief Deallocates the color-gradient divergence and reconstructed boundary arrays for surface tension. + !> Finalize the surface tension module impure subroutine s_finalize_surface_tension_module integer :: j diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 72b38eb486..1ef69f79ef 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -59,8 +59,7 @@ module m_time_steppers contains - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the time steppers module impure subroutine s_initialize_time_steppers_module #ifdef FRONTIER_UNIFIED @@ -453,7 +452,7 @@ contains end subroutine s_initialize_time_steppers_module - !> @brief Advances the solution one full step using a TVD Runge-Kutta time integrator. + !> Advance the solution one full step using a TVD Runge-Kutta time integrator impure subroutine s_tvd_rk(t_step, time_avg, nstage) #ifdef _CRAYFTN @@ -597,7 +596,6 @@ contains end subroutine s_tvd_rk !> Bubble source part in Strang operator splitting scheme - !! @param stage Current time-stage impure subroutine s_adaptive_dt_bubble(stage) integer, intent(in) :: stage @@ -625,7 +623,7 @@ contains end subroutine s_adaptive_dt_bubble - !> @brief Computes the global time step size from CFL stability constraints across all cells. + !> Compute the global time step size from CFL stability constraints across all cells impure subroutine s_compute_dt() real(wp) :: rho !< Cell-avg. density @@ -686,10 +684,7 @@ contains end subroutine s_compute_dt - !> This subroutine applies the body forces source term at each Runge-Kutta stage - !! @param q_cons_vf Conservative variables - !! @param q_prim_vf_in Primitive variables - !! @param rhs_vf_in Right-hand side variables + !> Apply the body forces source term at each Runge-Kutta stage subroutine s_apply_bodyforces(q_cons_vf, q_prim_vf_in, rhs_vf_in, ldt) type(scalar_field), dimension(1:sys_size), intent(inout) :: q_cons_vf @@ -717,7 +712,7 @@ contains end subroutine s_apply_bodyforces - !> @brief Updates immersed boundary positions and velocities at the current Runge-Kutta stage. + !> Update immersed boundary positions and velocities at the current Runge-Kutta stage subroutine s_propagate_immersed_boundaries(s) integer, intent(in) :: s @@ -785,8 +780,7 @@ contains end subroutine s_propagate_immersed_boundaries - !> This subroutine saves the temporary q_prim_vf vector into the q_prim_ts vector that is then used in p_main - !! @param t_step current time-step + !> Save the temporary q_prim_vf vector into q_prim_ts for use in p_main subroutine s_time_step_cycling(t_step) integer, intent(in) :: t_step diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 4b1c402205..0e5052fe21 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -26,7 +26,7 @@ module m_viscous contains - !> @brief Allocates and populates the viscous Reynolds number arrays and transfers data to the GPU. + !> Initialize the viscous module impure subroutine s_initialize_viscous_module integer :: i, j !< generic loop iterators @@ -44,10 +44,6 @@ contains end subroutine s_initialize_viscous_module !> Compute viscous stress tensor near cylindrical axis, avoiding 1/r singularity at y_cb(-1)=0 - !! @param q_prim_vf Cell-average primitive variables - !! @param grad_x_vf Cell-average primitive variable derivatives, x-direction - !! @param grad_y_vf Cell-average primitive variable derivatives, y-direction - !! @param grad_z_vf Cell-average primitive variable derivatives, z-direction subroutine s_compute_viscous_stress_cylindrical_boundary(q_prim_vf, grad_x_vf, grad_y_vf, grad_z_vf, tau_Re_vf, ix, iy, iz) type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf @@ -480,27 +476,6 @@ contains end subroutine s_compute_viscous_stress_cylindrical_boundary !> Computes viscous terms - !! @param qL_prim_rsx_vf Left reconstructed primitive variables in x - !! @param qL_prim_rsy_vf Left reconstructed primitive variables in y - !! @param qL_prim_rsz_vf Left reconstructed primitive variables in z - !! @param dqL_prim_dx_n Left primitive x-derivative - !! @param dqL_prim_dy_n Left primitive y-derivative - !! @param dqL_prim_dz_n Left primitive z-derivative - !! @param qL_prim Left cell-boundary primitive variables - !! @param qR_prim_rsx_vf Right reconstructed primitive variables in x - !! @param qR_prim_rsy_vf Right reconstructed primitive variables in y - !! @param qR_prim_rsz_vf Right reconstructed primitive variables in z - !! @param dqR_prim_dx_n Right primitive x-derivative - !! @param dqR_prim_dy_n Right primitive y-derivative - !! @param dqR_prim_dz_n Right primitive z-derivative - !! @param qR_prim Right cell-boundary primitive variables - !! @param q_prim_qp Cell-averaged primitive variables - !! @param dq_prim_dx_qp Cell-averaged primitive x-derivative - !! @param dq_prim_dy_qp Cell-averaged primitive y-derivative - !! @param dq_prim_dz_qp Cell-averaged primitive z-derivative - !! @param ix Index bounds in the x-direction - !! @param iy Index bounds in the y-direction - !! @param iz Index bounds in the z-direction subroutine s_get_viscous(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_n, dqL_prim_dy_n, dqL_prim_dz_n, & & qL_prim, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, & @@ -870,7 +845,7 @@ contains end subroutine s_get_viscous - !> @brief Reconstructs left and right cell-boundary values of viscous primitive variables using WENO or MUSCL. + !> Reconstruct left and right cell-boundary values of viscous primitive variables subroutine s_reconstruct_cell_boundary_values_visc(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & & vR_prim_vf, ix, iy, iz) @@ -968,7 +943,7 @@ contains end subroutine s_reconstruct_cell_boundary_values_visc - !> @brief Reconstructs left and right cell-boundary values of viscous primitive variable derivatives using WENO or MUSCL. + !> Reconstruct left and right cell-boundary values of viscous primitive variable derivatives subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & & vR_prim_vf, ix, iy, iz) @@ -1064,20 +1039,7 @@ contains end subroutine s_reconstruct_cell_boundary_values_visc_deriv - !> The purpose of this subroutine is to employ the inputted left and right cell-boundary integral-averaged variables to compute - !! the relevant cell-average first-order spatial derivatives in the x-, y- or z-direction by means of the scalar divergence - !! theorem. - !! @param vL_vf Left cell-boundary integral averages - !! @param vR_vf Right cell-boundary integral averages - !! @param dv_ds_vf Cell-average first-order spatial derivatives - !! @param norm_dir Splitting coordinate direction - !! @param ix Index bounds in the x-direction - !! @param iy Index bounds in the y-direction - !! @param iz Index bounds in the z-direction - !! @param iv_in Variable index bounds - !! @param dL Cell width array - !! @param dim Dimension size - !! @param buff_size_in Buffer layer size + !> Compute cell-average spatial derivatives via the scalar divergence theorem subroutine s_apply_scalar_divergence_theorem(vL_vf, vR_vf, dv_ds_vf, norm_dir, ix, iy, iz, iv_in, dL, dim, buff_size_in) ! arrays of cell widths @@ -1165,10 +1127,6 @@ contains end subroutine s_apply_scalar_divergence_theorem !> Computes the scalar gradient fields via finite differences - !! @param var Variable to compute derivative of - !! @param grad_x First coordinate direction component of the derivative - !! @param grad_y Second coordinate direction component of the derivative - !! @param grad_z Third coordinate direction component of the derivative subroutine s_compute_fd_gradient(var, grad_x, grad_y, grad_z) type(scalar_field), intent(in) :: var @@ -1331,7 +1289,7 @@ contains end subroutine s_compute_fd_gradient - !> @brief Computes the viscous stress tensor at a single grid cell using finite-difference velocity gradients. + !> Compute the viscous stress tensor at a single grid cell using finite-difference velocity gradients subroutine s_compute_viscous_stress_tensor(viscous_stress_tensor, q_prim_vf, dynamic_viscosity, i, j, k) $:GPU_ROUTINE(parallelism='[seq]') @@ -1396,7 +1354,7 @@ contains end subroutine s_compute_viscous_stress_tensor - !> @brief Deallocates the viscous Reynolds number arrays. + !> Finalize the viscous module impure subroutine s_finalize_viscous_module() @:DEALLOCATE(Res_viscous) diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index bc9167ea88..1c38c85911 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -82,8 +82,7 @@ module m_weno contains - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are necessary to setup the module. + !> Initialize the WENO module impure subroutine s_initialize_weno_module if (weno_order == 1) return @@ -170,10 +169,7 @@ contains end subroutine s_initialize_weno_module - !> The purpose of this subroutine is to compute the grid dependent coefficients of the WENO polynomials, ideal weights and - !! smoothness indicators, provided the order, the coordinate direction and the location of the WENO reconstruction. - !! @param weno_dir Coordinate direction of the WENO reconstruction - !! @param is Index bounds in the s-direction + !> Compute WENO polynomial coefficients, ideal weights, and smoothness indicators for a given direction subroutine s_compute_weno_coefficients(weno_dir, is) ! Compute WENO coefficients for a given coordinate direction. Shu (1997) @@ -860,7 +856,7 @@ contains end subroutine s_compute_weno_coefficients - !> @brief Performs WENO reconstruction of left and right cell-boundary values from cell-averaged variables. + !> Perform WENO reconstruction of left and right cell-boundary values from cell-averaged variables subroutine s_weno(v_vf, vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z, weno_dir, is1_weno_d, & & is2_weno_d, is3_weno_d) @@ -1386,10 +1382,7 @@ contains end subroutine s_weno - !> The computation of parameters, the allocation of memory, the association of pointers and/or the execution of any other - !! procedures that are required for the setup of the WENO reconstruction. - !! @param v_vf Cell-averaged variables - !! @param weno_dir Coordinate direction of the WENO reconstruction + !> Set up the WENO reconstruction for a given direction subroutine s_initialize_weno(v_vf, weno_dir) type(scalar_field), dimension(:), intent(in) :: v_vf @@ -1451,12 +1444,7 @@ contains end subroutine s_initialize_weno - !> The goal of this subroutine is to ensure that the WENO reconstruction is monotonic. The latter is achieved by enforcing - !! monotonicity preserving bounds of Suresh and Huynh (1997). The resulting MPWENO reconstruction, see Balsara and Shu (2000), - !! ensures that the reconstructed values do not reside outside the range spanned by WENO stencil. - !! @param v_rs_ws Reshaped cell-averaged variables - !! @param vL_rs_vf Left WENO reconstructed cell-boundary values - !! @param vR_rs_vf Right WENO reconstructed cell-boundary values + !> Enforce monotonicity-preserving bounds on the WENO reconstruction subroutine s_preserve_monotonicity(v_rs_ws, vL_rs_vf, vR_rs_vf) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: v_rs_ws From eeece9b7170dae90ac4b73873c7360900c58d4b6 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 19:37:56 -0400 Subject: [PATCH 22/25] Add missing subroutine headers; fix orphan !!, !!IB markers, !!> syntax --- src/common/m_compile_specific.f90 | 3 +-- src/common/m_derived_types.fpp | 12 +++++------- src/common/m_finite_differences.fpp | 1 + src/common/m_helper_basic.fpp | 1 + src/common/m_model.fpp | 9 +++++---- src/common/m_mpi_common.fpp | 11 ++++------- src/common/m_variables_conversion.fpp | 2 +- src/post_process/m_data_output.fpp | 1 + src/post_process/m_mpi_proxy.fpp | 4 +--- src/post_process/m_start_up.fpp | 2 +- src/pre_process/m_check_ib_patches.fpp | 3 +-- src/pre_process/m_check_patches.fpp | 5 +++-- src/pre_process/m_global_parameters.fpp | 13 ++++--------- src/pre_process/m_icpp_patches.fpp | 3 +-- src/simulation/m_cbc.fpp | 22 +++++++++++----------- src/simulation/m_checker.fpp | 1 + src/simulation/m_data_output.fpp | 2 ++ src/simulation/m_global_parameters.fpp | 8 ++------ src/simulation/m_hyperelastic.fpp | 4 ++-- src/simulation/m_ib_patches.fpp | 24 ++++++++---------------- src/simulation/m_ibm.fpp | 2 +- src/simulation/m_muscl.fpp | 1 + src/simulation/m_rhs.fpp | 8 ++------ src/simulation/m_riemann_solvers.fpp | 8 ++++---- src/simulation/m_start_up.fpp | 2 +- src/simulation/m_surface_tension.fpp | 1 + 26 files changed, 66 insertions(+), 87 deletions(-) diff --git a/src/common/m_compile_specific.f90 b/src/common/m_compile_specific.f90 index fda370dac8..9d79811320 100644 --- a/src/common/m_compile_specific.f90 +++ b/src/common/m_compile_specific.f90 @@ -12,8 +12,7 @@ module m_compile_specific contains - !> Creates a directory and all its parents if it does not exist - !! @param dir_name Directory path + !> Create a directory and all its parents if it does not exist impure subroutine s_create_directory(dir_name) character(LEN=*), intent(in) :: dir_name diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 39667a758d..6a301c1b1e 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -236,13 +236,11 @@ module m_derived_types real(wp) :: V0 !< Bubble velocity real(wp) :: p0 !< Bubble size real(wp) :: m0 !< Bubble velocity - integer :: hcid - !! id for hard coded initial condition + integer :: hcid !< Hardcoded initial condition ID + real(wp) :: cf_val !< Color function value + real(wp) :: Y(1:num_species) - real(wp) :: cf_val !! color function value - real(wp) :: Y(1:num_species) - - !! STL or OBJ model input parameter + ! STL or OBJ model input parameter character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. @@ -271,7 +269,7 @@ module m_derived_types real(wp) :: theta logical :: slip - !! STL or OBJ model input parameter + ! STL or OBJ model input parameter character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. diff --git a/src/common/m_finite_differences.fpp b/src/common/m_finite_differences.fpp index 98758c2a0e..efa4a2375e 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -13,6 +13,7 @@ module m_finite_differences contains + !> Accumulate the finite-difference divergence of a vector field onto a scalar field. subroutine s_compute_fd_divergence(div, fields, ix_s, iy_s, iz_s) type(scalar_field), intent(inout) :: div diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 17caabb99f..7567bc6c6f 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -98,6 +98,7 @@ contains end function f_is_integer + !> Compute ghost-cell buffer size and set interior/buffered coordinate index bounds. subroutine s_configure_coordinate_bounds(recon_type, weno_polyn, muscl_polyn, igr_order, buff_size, idwint, idwbuff, viscous, & & bubbles_lagrange, m, n, p, num_dims, igr, ib) diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index 528c58af77..ece301311f 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -28,10 +28,8 @@ module m_model public :: s_instantiate_STL_models #endif - !! array of STL models that can be allocated and then used in IB marker and levelset compute - type(t_model_array), allocatable, target :: models(:) - !! GPU-friendly flat arrays for STL model data - integer, allocatable :: gpu_ntrs(:) + type(t_model_array), allocatable, target :: models(:) !< STL/OBJ models for IB markers and levelset + integer, allocatable :: gpu_ntrs(:) !< GPU-friendly flat arrays for STL model data real(wp), allocatable, dimension(:,:,:,:) :: gpu_trs_v real(wp), allocatable, dimension(:,:,:) :: gpu_trs_n real(wp), allocatable, dimension(:,:,:,:) :: gpu_boundary_v @@ -414,6 +412,7 @@ contains end subroutine s_model_free + !> Read the next non-blank, non-comment line from an STL or OBJ model file. impure function f_read_line(iunit, line) result(bIsLine) integer, intent(in) :: iunit @@ -964,6 +963,7 @@ contains end subroutine s_distance_normals_2D #ifdef MFC_SIMULATION + !> Load, transform, and register STL/OBJ immersed-boundary models onto the simulation grid. subroutine s_instantiate_STL_models() ! Variables for IBM+STL @@ -1126,6 +1126,7 @@ contains end subroutine s_instantiate_STL_models #endif + !> Pack triangle vertices and normals from a model into flat arrays for GPU transfer. subroutine s_pack_model_for_gpu(ma) type(t_model_array), intent(inout) :: ma diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 7fdd087cbc..461fdb8a8e 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -22,7 +22,6 @@ module m_mpi_common integer, private :: v_size $:GPU_DECLARE(create='[v_size]') - !! Generic flags used to identify and report MPI errors !> This variable is utilized to pack and send the buffer of the cell-average primitive variables, for a single computational !! domain boundary at the time, to the relevant neighboring processor. @@ -99,6 +98,7 @@ contains end subroutine s_mpi_initialize + !> Set up MPI I/O data views and variable pointers for parallel file output. impure subroutine s_initialize_mpi_data(q_cons_vf, ib_markers, beta) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -180,6 +180,7 @@ contains end subroutine s_initialize_mpi_data + !> Set up MPI I/O data views for downsampled (coarsened) parallel file output. subroutine s_initialize_mpi_data_ds(q_cons_vf) type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf @@ -401,9 +402,7 @@ contains end subroutine s_mpi_allreduce_max - !> Reduce a local real value to its global minimum and broadcast the result to all ranks. - ! ! @param var_loc holds the local value to be reduced among all the processors in communicator. On output, the variable holds - ! the minimum value, reduced amongst all of the local values. + !> Reduce a local real value to its global minimum across all ranks impure subroutine s_mpi_reduce_min(var_loc) real(wp), intent(inout) :: var_loc @@ -422,9 +421,7 @@ contains end subroutine s_mpi_reduce_min !> Reduce a 2-element variable to its global maximum value with the owning processor rank (MPI_MAXLOC). - ! ! @param var_loc On input, this variable holds the local value and processor rank, which are to be reduced among all the - ! processors in communicator. On output, this variable holds the maximum value, reduced amongst all of the local values, and the - ! process rank to which the value belongs. + !> Reduce a local value to its global maximum with location (rank) across all ranks impure subroutine s_mpi_reduce_maxloc(var_loc) real(wp), dimension(2), intent(inout) :: var_loc diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 21dacbc8cd..cdd9c26ad7 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -37,7 +37,7 @@ module m_variables_conversion #endif s_finalize_variables_conversion_module - !! In simulation, gammas, pi_infs, and qvs are already declared in m_global_variables + ! In simulation, gammas, pi_infs, and qvs are already declared in m_global_variables #ifndef MFC_SIMULATION real(wp), allocatable, public, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps $:GPU_DECLARE(create='[gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps]') diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index f3db054290..51fa34a4a1 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -1114,6 +1114,7 @@ contains end subroutine s_write_lag_variable_to_formatted_database_file + !> Convert the binary immersed-boundary state file to per-body formatted text files impure subroutine s_write_ib_state_files() character(len=len_trim(case_dir) + 4*name_len) :: in_file, out_file, file_loc diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index c462eca096..19f899ff71 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -138,9 +138,7 @@ contains end subroutine s_mpi_bcast_user_inputs - !> Gather the Silo database metadata for the spatial extents to boost the performance of the multidimensional visualization. - ! ! @param spatial_extents Spatial extents for each processor's sub-domain. First dimension corresponds to the minimum and - ! maximum values, respectively, while the second dimension corresponds to the processor rank. + !> Gather spatial extents from all ranks for Silo database metadata impure subroutine s_mpi_gather_spatial_extents(spatial_extents) real(wp), dimension(1:, 0:), intent(inout) :: spatial_extents diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 038fd26867..e964265775 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -725,7 +725,7 @@ contains end if if (bubbles_lagrange) then - !! Void fraction field + ! 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) write (varname, '(A)') 'voidFraction' diff --git a/src/pre_process/m_check_ib_patches.fpp b/src/pre_process/m_check_ib_patches.fpp index 16a74020f9..844d051716 100644 --- a/src/pre_process/m_check_ib_patches.fpp +++ b/src/pre_process/m_check_ib_patches.fpp @@ -209,8 +209,7 @@ contains end subroutine s_check_model_ib_patch_geometry - !!> This subroutine verifies that the geometric parameters of - !! the inactive patch remain unaltered by the user inputs. @param patch_id Patch identifier + !> Verify that inactive IB patch geometry parameters remain at defaults impure subroutine s_check_inactive_ib_patch_geometry(patch_id) integer, intent(in) :: patch_id diff --git a/src/pre_process/m_check_patches.fpp b/src/pre_process/m_check_patches.fpp index e9b41f761f..adcb233f97 100644 --- a/src/pre_process/m_check_patches.fpp +++ b/src/pre_process/m_check_patches.fpp @@ -243,6 +243,7 @@ contains end subroutine s_check_sphere_patch_geometry + !> Validate geometry parameters for a 2D modal (Fourier) patch impure subroutine s_check_2d_modal_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -257,6 +258,7 @@ contains end subroutine s_check_2d_modal_patch_geometry + !> Validate geometry parameters for a 3D spherical harmonic patch impure subroutine s_check_3d_spherical_harmonic_patch_geometry(patch_id) integer, intent(in) :: patch_id @@ -356,8 +358,7 @@ contains end subroutine s_check_ellipsoid_patch_geometry - !!> This subroutine verifies that the geometric parameters of - !! the inactive patch remain unaltered by the user inputs. @param patch_id Patch identifier + !> Verify that inactive patch geometry parameters remain at defaults impure subroutine s_check_inactive_patch_geometry(patch_id) integer, intent(in) :: patch_id diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index caaf97d69f..ea2399f871 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -153,9 +153,7 @@ module m_global_parameters type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp integer :: num_bc_patches !< Number of boundary condition patches logical :: bc_io !< whether or not to save BC data - type(bc_patch_parameters), dimension(num_bc_patches_max) :: patch_bc - !! Database of the boundary condition patch parameters for each of the patches employed in the configuration of the boundary - !! conditions + type(bc_patch_parameters), dimension(num_bc_patches_max) :: patch_bc !< Boundary condition patch parameters ! Fluids Physical Parameters !> Database of the physical parameters of each of the fluids that is present in the flow. These include the stiffened gas @@ -179,14 +177,11 @@ module m_global_parameters !> @name Immersed Boundaries !> @{ - logical :: ib !< Turn immersed boundaries on - integer :: num_ibs !< Number of immersed boundaries + logical :: ib !< Turn immersed boundaries on + integer :: num_ibs !< Number of immersed boundaries integer :: Np - type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib + type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib !< Immersed boundary patch parameters type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l - !! Database of the immersed boundary patch parameters for each of the patches employed in the configuration of the initial - !! condition. Note that the maximum allowable number of patches, num_patches_max, may be changed in the module - !! m_derived_types.f90. !> @} !> @name Non-polytropic bubble gas compression diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index a2274c02fa..188eb23f9f 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -982,8 +982,7 @@ contains @:HardcodedDimensionsExtrusion() @:Hardcoded3DVariables() - !! Variables to initialize the pressure field that corresponds to the bubble-collapse test case found in Tiwari et al. - !! (2013) + ! Variables to initialize the pressure field that corresponds to the bubble-collapse test case found in Tiwari et al. (2013) ! Transferring spherical patch's radius, centroid, smoothing patch identity and smoothing coefficient information x_centroid = patch_icpp(patch_id)%x_centroid diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index d57e013536..cd937f3595 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -23,25 +23,25 @@ module m_cbc private; public :: s_initialize_cbc_module, s_cbc, s_finalize_cbc_module - !! The cell-average primitive variables. They are obtained by reshaping (RS) q_prim_vf in the coordinate direction normal to the - !! domain boundary along which the CBC is applied. + ! The cell-average primitive variables. They are obtained by reshaping (RS) q_prim_vf in the coordinate direction normal to the + ! domain boundary along which the CBC is applied. real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsx_vf real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsy_vf real(wp), allocatable, dimension(:,:,:,:) :: q_prim_rsz_vf $:GPU_DECLARE(create='[q_prim_rsx_vf, q_prim_rsy_vf, q_prim_rsz_vf]') - !! Cell-average fluxes (src - source). These are directly determined from the cell-average primitive variables, q_prims_rs_vf, - !! and not a Riemann solver. + ! Cell-average fluxes (src - source). These are directly determined from the cell-average primitive variables, q_prims_rs_vf, + ! and not a Riemann solver. real(wp), allocatable, dimension(:,:,:,:) :: F_rsx_vf, F_src_rsx_vf real(wp), allocatable, dimension(:,:,:,:) :: F_rsy_vf, F_src_rsy_vf real(wp), allocatable, dimension(:,:,:,:) :: F_rsz_vf, F_src_rsz_vf $:GPU_DECLARE(create='[F_rsx_vf, F_src_rsx_vf, F_rsy_vf, F_src_rsy_vf, F_rsz_vf, F_src_rsz_vf]') - !! There is a CCE bug that is causing some subset of these variables to interfere with variables of the same name in - !! m_riemann_solvers.fpp, and giving this versions unique "_l" names works around the bug. Other private module allocatable - !! arrays in `acc declare create` clauses don't have this problem, so we still need to isolate this bug. + ! There is a CCE bug that is causing some subset of these variables to interfere with variables of the same name in + ! m_riemann_solvers.fpp, and giving this versions unique "_l" names works around the bug. Other private module allocatable + ! arrays in `acc declare create` clauses don't have this problem, so we still need to isolate this bug. real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf_l, flux_src_rsx_vf_l real(wp), allocatable, dimension(:,:,:,:) :: flux_rsy_vf_l, flux_src_rsy_vf_l @@ -63,8 +63,8 @@ module m_cbc real(wp), allocatable, dimension(:,:,:) :: pi_coef_z !< Polynomial interpolant coefficients in z-dir $:GPU_DECLARE(create='[ds, fd_coef_x, fd_coef_y, fd_coef_z, pi_coef_x, pi_coef_y, pi_coef_z]') - !! The first dimension of the array identifies the polynomial, the second dimension identifies the position of its coefficients - !! and the last dimension denotes the location of the CBC. + ! The first dimension of the array identifies the polynomial, the second dimension identifies the position of its coefficients + ! and the last dimension denotes the location of the CBC. type(int_bounds_info) :: is1, is2, is3 !< Indical bounds in the s1-, s2- and s3-directions $:GPU_DECLARE(create='[is1, is2, is3]') @@ -76,8 +76,8 @@ module m_cbc $:GPU_DECLARE(create='[dj, bcxb, bcxe, bcyb, bcye, bczb, bcze]') $:GPU_DECLARE(create='[cbc_dir, cbc_loc, flux_cbc_index]') - !! GRCBC inputs for subsonic inflow and outflow conditions consisting of inflow velocities, pressure, density and void fraction - !! as well as outflow velocities and pressure + ! GRCBC inputs for subsonic inflow and outflow conditions consisting of inflow velocities, pressure, density and void fraction + ! as well as outflow velocities and pressure real(wp), allocatable, dimension(:) :: pres_in, pres_out, Del_in, Del_out real(wp), allocatable, dimension(:,:) :: vel_in, vel_out diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index 6153b7b287..d8c194f9b2 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -91,6 +91,7 @@ contains end subroutine s_check_inputs_time_stepping + !> Validate NVIDIA unified virtual memory configuration parameters impure subroutine s_check_inputs_nvidia_uvm #ifdef __NVCOMPILER_GPU_UNIFIED_MEM diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 296eca7a1a..0c5df018ae 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -164,6 +164,7 @@ contains end subroutine s_open_probe_files + !> Open the immersed boundary state file for binary output impure subroutine s_open_ib_state_file character(len=path_len + 2*name_len) :: file_loc @@ -1536,6 +1537,7 @@ contains end subroutine s_close_probe_files + !> Close the immersed boundary state file impure subroutine s_close_ib_state_file close (ib_state_unit) diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 56528b7974..443768dd93 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -57,8 +57,7 @@ module m_global_parameters !> @{ real(wp), target, allocatable, dimension(:) :: x_cc, y_cc, z_cc !> @} - ! type(bounds_info) :: x_domain, y_domain, z_domain !< - !! Locations of the domain bounds in the x-, y- and z-coordinate directions + ! type(bounds_info) :: x_domain, y_domain, z_domain !< Locations of the domain bounds in the x-, y- and z-coordinate directions !> @name Cell-width distributions in the x-, y- and z-directions, respectively !> @{ real(wp), target, allocatable, dimension(:) :: dx, dy, dz @@ -360,12 +359,9 @@ module m_global_parameters logical :: ib integer :: num_ibs logical :: ib_state_wrt - type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib + type(ib_patch_parameters), dimension(num_patches_max) :: patch_ib !< Immersed boundary patch parameters type(vec3_dt), allocatable, dimension(:) :: airfoil_grid_u, airfoil_grid_l integer :: Np - !! Database of the immersed boundary patch parameters for each of the patches employed in the configuration of the initial - !! condition. Note that the maximum allowable number of patches, num_patches_max, may be changed in the module - !! m_derived_types.f90. $:GPU_DECLARE(create='[ib, num_ibs, patch_ib, Np, airfoil_grid_u, airfoil_grid_l]') !> @} diff --git a/src/simulation/m_hyperelastic.fpp b/src/simulation/m_hyperelastic.fpp index 06c567d1fe..22c2aace73 100644 --- a/src/simulation/m_hyperelastic.fpp +++ b/src/simulation/m_hyperelastic.fpp @@ -17,8 +17,8 @@ module m_hyperelastic private; public :: s_hyperelastic_rmt_stress_update, s_initialize_hyperelastic_module, s_finalize_hyperelastic_module - !! The btensor at the cell-interior Gaussian quadrature points. These tensor is needed to be calculated once and make the code - !! DRY. + ! The btensor at the cell-interior Gaussian quadrature points. These tensor is needed to be calculated once and make the code + ! DRY. type(vector_field) :: btensor $:GPU_DECLARE(create='[btensor]') diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index d1f41937ec..dbbbfa5327 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -32,20 +32,20 @@ module m_ib_patches integer :: smooth_patch_id real(wp) :: smooth_coeff $:GPU_DECLARE(create='[smooth_patch_id, smooth_coeff]') - !! These variables are analogous in both meaning and use to the similarly named components in the ic_patch_parameters type (see - !! m_derived_types.f90 for additional details). They are employed as a means to more concisely perform the actions necessary to - !! lay out a particular patch on the grid. + ! These variables are analogous in both meaning and use to the similarly named components in the ic_patch_parameters type (see + ! m_derived_types.f90 for additional details). They are employed as a means to more concisely perform the actions necessary to + ! lay out a particular patch on the grid. real(wp) :: cart_x, cart_y, cart_z real(wp) :: sph_phi $:GPU_DECLARE(create='[cart_x, cart_y, cart_z, sph_phi]') - !! Variables to be used to hold cell locations in Cartesian coordinates if 3D simulation is using cylindrical coordinates + ! Variables to be used to hold cell locations in Cartesian coordinates if 3D simulation is using cylindrical coordinates type(bounds_info) :: x_boundary, y_boundary, z_boundary $:GPU_DECLARE(create='[x_boundary, y_boundary, z_boundary]') - !! These variables combine the centroid and length parameters associated with a particular patch to yield the locations of the - !! patch boundaries in the x-, y- and z-coordinate directions. They are used as a means to concisely perform the actions - !! necessary to lay out a particular patch on the grid. + ! These variables combine the centroid and length parameters associated with a particular patch to yield the locations of the + ! patch boundaries in the x-, y- and z-coordinate directions. They are used as a means to concisely perform the actions + ! necessary to lay out a particular patch on the grid. character(len=5) :: istr ! string to store int to string result for error checking @@ -277,13 +277,11 @@ contains end do if (f_approx_equal(airfoil_grid_u(k)%x, xy_local(1))) then if (xy_local(2) <= airfoil_grid_u(k)%y) then - !!IB ib_markers%sf(i, j, 0) = encoded_patch_id end if else f = (airfoil_grid_u(k)%x - xy_local(1))/(airfoil_grid_u(k)%x - airfoil_grid_u(k - 1)%x) if (xy_local(2) <= ((1._wp - f)*airfoil_grid_u(k)%y + f*airfoil_grid_u(k - 1)%y)) then - !!IB ib_markers%sf(i, j, 0) = encoded_patch_id end if end if @@ -294,14 +292,12 @@ contains end do if (f_approx_equal(airfoil_grid_l(k)%x, xy_local(1))) then if (xy_local(2) >= airfoil_grid_l(k)%y) then - !!IB ib_markers%sf(i, j, 0) = encoded_patch_id end if else f = (airfoil_grid_l(k)%x - xy_local(1))/(airfoil_grid_l(k)%x - airfoil_grid_l(k - 1)%x) if (xy_local(2) >= ((1._wp - f)*airfoil_grid_l(k)%y + f*airfoil_grid_l(k - 1)%y)) then - !!IB ib_markers%sf(i, j, 0) = encoded_patch_id end if end if @@ -440,7 +436,6 @@ contains else f = (airfoil_grid_u(k)%x - xyz_local(1))/(airfoil_grid_u(k)%x - airfoil_grid_u(k - 1)%x) if (xyz_local(2) <= ((1._wp - f)*airfoil_grid_u(k)%y + f*airfoil_grid_u(k - 1)%y)) then - !!IB ib_markers%sf(i, j, l) = encoded_patch_id end if end if @@ -451,14 +446,12 @@ contains end do if (f_approx_equal(airfoil_grid_l(k)%x, xyz_local(1))) then if (xyz_local(2) >= airfoil_grid_l(k)%y) then - !!IB ib_markers%sf(i, j, l) = encoded_patch_id end if else f = (airfoil_grid_l(k)%x - xyz_local(1))/(airfoil_grid_l(k)%x - airfoil_grid_l(k - 1)%x) if (xyz_local(2) >= ((1._wp - f)*airfoil_grid_l(k)%y + f*airfoil_grid_l(k - 1)%y)) then - !!IB ib_markers%sf(i, j, l) = encoded_patch_id end if end if @@ -538,8 +531,7 @@ contains real(wp) :: radius real(wp), dimension(1:3) :: center - !! Variables to initialize the pressure field that corresponds to the bubble-collapse test case found in Tiwari et al. - !! (2013) + ! Variables to initialize the pressure field that corresponds to the bubble-collapse test case found in Tiwari et al. (2013) ! Transferring spherical patch's radius, centroid, smoothing patch identity and smoothing coefficient information diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 88294c7917..1e9f07e5c5 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -151,7 +151,7 @@ contains real(wp), dimension(nb*nmom) :: nmom_IP real(wp), dimension(nb*nnode) :: presb_IP, massv_IP #:endif - !! Primitive variables at the image point associated with a ghost point, interpolated from surrounding fluid cells. + ! Primitive variables at the image point associated with a ghost point, interpolated from surrounding fluid cells. real(wp), dimension(3) :: norm !< Normal vector from GP to IP real(wp), dimension(3) :: physical_loc !< Physical loc of GP diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index 7dc51afaf3..2dcf0ff050 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -37,6 +37,7 @@ module m_muscl contains + !> Allocate and initialize MUSCL reconstruction working arrays subroutine s_initialize_muscl_module() ! Initializing in x-direction diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 46461b440a..4a03837d3a 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -38,14 +38,10 @@ module m_rhs private; public :: s_initialize_rhs_module, s_compute_rhs, s_finalize_rhs_module - !! This variable contains the WENO-reconstructed values of the cell-average conservative variables, which are located in - !! q_cons_vf, at cell-interior Gaussian quadrature points (QP). - type(vector_field) :: q_cons_qp + type(vector_field) :: q_cons_qp !< WENO-reconstructed cell-average conservative variables at quadrature points $:GPU_DECLARE(create='[q_cons_qp]') - !! The primitive variables at cell-interior Gaussian quadrature points. These are calculated from the conservative variables and - !! gradient magnitude (GM) of the volume fractions, q_cons_qp and gm_alpha_qp, respectively. - type(vector_field) :: q_prim_qp + type(vector_field) :: q_prim_qp !< Primitive variables at cell-interior quadrature points $:GPU_DECLARE(create='[q_prim_qp]') !> @name The first-order spatial derivatives of the primitive variables at cell- interior Gaussian quadrature points. These are diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index c08264c153..c5e9ce95f2 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -136,7 +136,7 @@ contains end subroutine s_compute_viscous_source_flux - ! HLL approximate Riemann solver, Harten et al. SIAM Review (1983) + !> HLL approximate Riemann solver, Harten et al. SIAM Review (1983) subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & @@ -813,7 +813,7 @@ contains end subroutine s_hll_riemann_solver - ! Lax-Friedrichs (Rusanov) approximate Riemann solver + !> Lax-Friedrichs (Rusanov) approximate Riemann solver subroutine s_lf_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & @@ -1681,7 +1681,7 @@ contains end subroutine s_lf_riemann_solver - ! HLLC Riemann solver with contact restoration, Toro et al. Shock Waves (1994) + !> HLLC Riemann solver with contact restoration, Toro et al. Shock Waves (1994) subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & @@ -3294,7 +3294,7 @@ contains end subroutine s_hllc_riemann_solver - ! HLLD Riemann solver for MHD, Miyoshi & Kusano JCP (2005) + !> HLLD Riemann solver for MHD, Miyoshi & Kusano JCP (2005) subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index 49fb11c26d..c4ff3663ee 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -77,7 +77,7 @@ contains character(LEN=name_len), parameter :: file_path = './simulation.inp' logical :: file_exist !< Logical used to check the existence of the input file integer :: iostatus - !! Integer to check iostat of file read + ! Integer to check iostat of file read character(len=1000) :: line diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index b5af98d8fa..11229d9e3f 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -40,6 +40,7 @@ module m_surface_tension contains + !> Allocate and initialize surface tension module arrays impure subroutine s_initialize_surface_tension_module integer :: j From 10c5a16ba3a87fcd12d2f098ec483c576c99a8e7 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Sun, 22 Mar 2026 20:25:34 -0400 Subject: [PATCH 23/25] Fix Doxygen markers: !! to !<, !!< to !<, inline variable docs, condense verbose headers --- src/common/m_derived_types.fpp | 52 ++++++++++++------------ src/post_process/m_global_parameters.fpp | 2 +- src/post_process/p_main.fpp | 5 +-- src/pre_process/m_global_parameters.fpp | 4 +- src/simulation/m_cbc.fpp | 4 +- src/simulation/m_global_parameters.fpp | 4 +- src/simulation/m_riemann_solvers.fpp | 51 +++++++++++------------ src/simulation/m_weno.fpp | 9 +--- 8 files changed, 59 insertions(+), 72 deletions(-) diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 6a301c1b1e..d5180d389a 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -147,38 +147,38 @@ module m_derived_types end type ic_model_parameters type :: t_triangle - real(wp), dimension(1:3, 1:3) :: v ! Vertices of the triangle - real(wp), dimension(1:3) :: n ! Normal vector + real(wp), dimension(1:3, 1:3) :: v !< Vertices of the triangle + real(wp), dimension(1:3) :: n !< Normal vector end type t_triangle type :: t_ray - real(wp), dimension(1:3) :: o ! Origin - real(wp), dimension(1:3) :: d ! Direction + real(wp), dimension(1:3) :: o !< Origin + real(wp), dimension(1:3) :: d !< Direction end type t_ray type :: t_bbox - real(wp), dimension(1:3) :: min ! Minimum coordinates - real(wp), dimension(1:3) :: max ! Maximum coordinates + real(wp), dimension(1:3) :: min !< Minimum coordinates + real(wp), dimension(1:3) :: max !< Maximum coordinates end type t_bbox type :: t_model - integer :: ntrs ! Number of triangles - type(t_triangle), allocatable :: trs(:) ! Triangles + integer :: ntrs !< Number of triangles + type(t_triangle), allocatable :: trs(:) !< Triangles end type t_model type :: t_model_array ! Original CPU-side fields (unchanged) - type(t_model), allocatable :: model - real(wp), allocatable, dimension(:,:,:) :: boundary_v - real(wp), allocatable, dimension(:,:) :: interpolated_boundary_v - integer :: boundary_edge_count - integer :: total_vertices - integer :: interpolate + type(t_model), allocatable :: model !< STL/OBJ geometry model + real(wp), allocatable, dimension(:,:,:) :: boundary_v !< Boundary vertices + real(wp), allocatable, dimension(:,:) :: interpolated_boundary_v !< Interpolated boundary vertices + integer :: boundary_edge_count !< Number of boundary edges + integer :: total_vertices !< Total vertex count + integer :: interpolate !< Interpolation flag ! GPU-friendly flattened arrays - integer :: ntrs ! copy of model%ntrs - real(wp), allocatable, dimension(:,:,:) :: trs_v ! (3, 3, ntrs) - triangle vertices - real(wp), allocatable, dimension(:,:) :: trs_n ! (3, ntrs) - triangle normals + integer :: ntrs !< Copy of model%ntrs + real(wp), allocatable, dimension(:,:,:) :: trs_v !< Triangle vertices (3, 3, ntrs) + real(wp), allocatable, dimension(:,:) :: trs_n !< Triangle normals (3, ntrs) end type t_model_array !> Derived type adding initial condition (ic) patch parameters as attributes NOTE: The requirements for the specification of the @@ -230,15 +230,15 @@ module m_derived_types !> Primitive variables associated with the patch. In order, these include the partial densities, density, velocity, !! pressure, volume fractions, specific heat ratio function and the liquid stiffness function. real(wp) :: qvp - real(wp) :: Bx, By, Bz !< Magnetic field components; B%x is not used for 1D - real(wp), dimension(6) :: tau_e !< Elastic stresses added to primitive variables if hypoelasticity = True - real(wp) :: R0 !< Bubble size - real(wp) :: V0 !< Bubble velocity - real(wp) :: p0 !< Bubble size - real(wp) :: m0 !< Bubble velocity - integer :: hcid !< Hardcoded initial condition ID - real(wp) :: cf_val !< Color function value - real(wp) :: Y(1:num_species) + real(wp) :: Bx, By, Bz !< Magnetic field components; B%x is not used for 1D + real(wp), dimension(6) :: tau_e !< Elastic stresses added to primitive variables if hypoelasticity = True + real(wp) :: R0 !< Bubble size + real(wp) :: V0 !< Bubble velocity + real(wp) :: p0 !< Bubble size + real(wp) :: m0 !< Bubble velocity + integer :: hcid !< Hardcoded initial condition ID + real(wp) :: cf_val !< Color function value + real(wp) :: Y(1:num_species) !< Species mass fractions ! STL or OBJ model input parameter character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index 4aec00b595..0fd3dc4fd7 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -146,7 +146,7 @@ module m_global_parameters type(int_bounds_info) :: bc_x, bc_y, bc_z !> @} - integer :: shear_num !! Number of shear stress components + integer :: shear_num !< Number of shear stress components integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, diff --git a/src/post_process/p_main.fpp b/src/post_process/p_main.fpp index 25f5939318..32d8dc2c7e 100644 --- a/src/post_process/p_main.fpp +++ b/src/post_process/p_main.fpp @@ -2,10 +2,7 @@ !! @file !! @brief Contains program p_main -!> @brief Restructure raw simulation data into a formatted database (Silo-HDF5 or Binary, chosen by the user. The user may also -!! specify which variables to include in the database. The choices range from any one of the primitive and conservative variables, -!! as well as quantities that can be derived from those such as the unadvected volume fraction, specific heat ratio, liquid -!! stiffness, speed of sound, vorticity and the numerical Schlieren function. +!> Post-process raw simulation data into formatted database files (Silo-HDF5 or Binary) program p_main use m_global_parameters diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index ea2399f871..73820a165e 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -105,7 +105,7 @@ module m_global_parameters ! Cell indices (InDices With BUFFer): includes buffer except in pre_process type(int_bounds_info) :: idwbuff(1:3) type(int_bounds_info) :: bc_x, bc_y, bc_z !< Boundary conditions in the x-, y- and z-coordinate directions - integer :: shear_num !! Number of shear stress components + integer :: shear_num !< Number of shear stress components integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, @@ -622,7 +622,7 @@ contains bub_idx%beg = sys_size + 1 if (qbmm) then if (nnode == 4) then - nmom = 6 !! Already set as a parameter + nmom = 6 !< Already set as a parameter end if bub_idx%end = adv_idx%end + nb*nmom else diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index cd937f3595..1614b340b0 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -53,9 +53,7 @@ module m_cbc real(wp), allocatable, dimension(:,:) :: fd_coef_x !< Finite diff. coefficients x-dir real(wp), allocatable, dimension(:,:) :: fd_coef_y !< Finite diff. coefficients y-dir - !> Finite diff. coefficients z-dir The first dimension identifies the location of a coefficient in the FD formula, while the - !! last dimension denotes the location of the CBC. - real(wp), allocatable, dimension(:,:) :: fd_coef_z + real(wp), allocatable, dimension(:,:) :: fd_coef_z !< Finite diff. coefficients, z-direction ! Bug with NVHPC when using nullified pointers in a declare create real(wp), pointer, dimension(:, :) :: fd_coef => null() real(wp), allocatable, dimension(:,:,:) :: pi_coef_x !< Polynomial interpolant coefficients in x-dir diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 443768dd93..b8c96aff23 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -306,7 +306,7 @@ module m_global_parameters !> @{ integer, dimension(3) :: dir_idx real(wp), dimension(3) :: dir_flg - integer, dimension(3) :: dir_idx_tau !!used for hypoelasticity=true + integer, dimension(3) :: dir_idx_tau !< used for hypoelasticity=true !> @} $:GPU_DECLARE(create='[dir_idx, dir_flg, dir_idx_tau]') @@ -316,7 +316,7 @@ module m_global_parameters integer :: buff_size $:GPU_DECLARE(create='[buff_size]') - integer :: shear_num !! Number of shear stress components + integer :: shear_num !< Number of shear stress components integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index c5e9ce95f2..73e796f7a8 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -4127,35 +4127,32 @@ contains ! 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. - - real(wp), & - & dimension(3) & - & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + 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). - real(wp), & - & dimension(num_dims) :: vel_src_int !!< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. - real(wp), & - & dimension(num_dims) & - & :: stress_vector_shear !!< Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + 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) :: 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. $: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]') diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 1c38c85911..0385ccea23 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -1460,13 +1460,8 @@ contains real(wp) :: vL_min, vR_min real(wp) :: vL_max, vR_max ! Monotonicity-preserving bounds, Suresh & Huynh JCP (1997) - real(wp), parameter :: alpha = 2._wp !> - !! Determines the maximum Courant-Friedrichs-Lewy (CFL) number that may be utilized with the scheme. In theory, for - !! stability, a CFL number less than 1/(1+alpha) is necessary. The default value for alpha is 2. - - !> Determines the amount of freedom available from utilizing a large value for the local curvature. The default value for - !! beta is 4/3. - real(wp), parameter :: beta = 4._wp/3._wp + real(wp), parameter :: alpha = 2._wp !< Max CFL stability parameter (CFL < 1/(1+alpha)) + real(wp), parameter :: beta = 4._wp/3._wp !< Local curvature freedom parameter real(wp), parameter :: alpha_mp = 2._wp real(wp), parameter :: beta_mp = 4._wp/3._wp From e96eb980f7258827ac387c71309d73b088a8a0bd Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Mon, 23 Mar 2026 18:23:40 -0400 Subject: [PATCH 24/25] Rename ffmt.toml to .ffmt.toml, fix corrupted UTF-8 em-dashes, add missing :: --- ffmt.toml => .ffmt.toml | 0 src/simulation/m_data_output.fpp | 2 +- src/simulation/m_ibm.fpp | 3 +-- 3 files changed, 2 insertions(+), 3 deletions(-) rename ffmt.toml => .ffmt.toml (100%) diff --git a/ffmt.toml b/.ffmt.toml similarity index 100% rename from ffmt.toml rename to .ffmt.toml diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index 0c5df018ae..ad27a515e5 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -86,7 +86,7 @@ contains open (3, FILE=trim(file_path), form='formatted', STATUS='replace') write (3, '(A)') 'Description: Stability information at ' // 'each time-step of the simulation. This' - write (3, '(13X,A)') 'data is composed of the inviscid ' // 'Courant–Friedrichs–Lewy (ICFL)' + write (3, '(13X,A)') 'data is composed of the inviscid ' // 'Courant-Friedrichs-Lewy (ICFL)' write (3, '(13X,A)') 'number, the viscous CFL (VCFL) number, ' // 'the capillary CFL (CCFL)' write (3, '(13X,A)') 'number and the cell Reynolds (Rc) ' // 'number. Please note that only' write (3, '(13X,A)') 'those stability conditions pertinent ' // 'to the physics included in' diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 1e9f07e5c5..6c5799a8e0 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -622,8 +622,7 @@ contains type(ghost_point) :: gp integer :: q, i, j, k, ii, jj, kk !< Grid indexes and iterators integer :: patch_id - - logical is_cell_center + logical :: is_cell_center $:GPU_PARALLEL_LOOP(private='[q, i, j, k, ii, jj, kk, dist, buf, gp, interp_coeffs, eta, alpha, patch_id, is_cell_center]') do q = 1, num_gps From c00be3ed7b034b835cd0601ec5a2d2b97ce13561 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Tue, 24 Mar 2026 21:05:40 -0400 Subject: [PATCH 25/25] Compact slice subscripts, fix remaining Doxygen inline comments Enable ffmt slice-colon=false: normalize array subscript spacing to compact form (e.g. a(:, :, 1) -> a(:,:,1)). Convert remaining bare ! inline comments on declarations to !< and condense multi-line !> blocks to inline !<. Co-Authored-By: Claude Opus 4.6 (1M context) --- .ffmt.toml | 1 + src/common/include/3dHardcodedIC.fpp | 16 +-- src/common/include/ExtrusionHardcodedIC.fpp | 12 +- src/common/m_boundary_common.fpp | 108 +++++++------- src/common/m_constants.fpp | 4 +- src/common/m_delay_file_access.f90 | 2 + src/common/m_derived_types.fpp | 148 +++++++++----------- src/common/m_finite_differences.fpp | 2 +- src/common/m_helper.fpp | 25 ++-- src/common/m_helper_basic.fpp | 1 + src/common/m_model.fpp | 104 +++++++------- src/common/m_mpi_common.fpp | 54 +++---- src/common/m_nvtx.f90 | 10 +- src/common/m_phase_change.fpp | 33 +++-- src/common/m_precision_select.f90 | 6 +- src/common/m_variables_conversion.fpp | 86 ++++++------ src/post_process/m_data_input.f90 | 32 ++--- src/post_process/m_data_output.fpp | 71 +++++----- src/post_process/m_derived_variables.fpp | 54 +++---- src/post_process/m_global_parameters.fpp | 61 +++----- src/post_process/m_mpi_proxy.fpp | 6 +- src/post_process/m_start_up.fpp | 64 ++++----- src/pre_process/m_assign_variables.fpp | 17 ++- src/pre_process/m_boundary_conditions.fpp | 24 ++-- src/pre_process/m_data_output.fpp | 50 +++---- src/pre_process/m_global_parameters.fpp | 79 +++++------ src/pre_process/m_icpp_patches.fpp | 114 +++++++-------- src/pre_process/m_initial_condition.fpp | 26 ++-- src/pre_process/m_perturbation.fpp | 8 +- src/pre_process/m_start_up.fpp | 8 +- src/simulation/m_acoustic_src.fpp | 14 +- src/simulation/m_bubbles.fpp | 1 + src/simulation/m_bubbles_EE.fpp | 1 + src/simulation/m_bubbles_EL.fpp | 136 +++++++++--------- src/simulation/m_bubbles_EL_kernels.fpp | 67 ++++----- src/simulation/m_cbc.fpp | 7 +- src/simulation/m_checker.fpp | 1 + src/simulation/m_compute_cbc.fpp | 1 + src/simulation/m_compute_levelset.fpp | 19 +-- src/simulation/m_data_output.fpp | 38 ++--- src/simulation/m_derived_variables.fpp | 4 +- src/simulation/m_fftw.fpp | 8 +- src/simulation/m_global_parameters.fpp | 54 +++---- src/simulation/m_hypoelastic.fpp | 2 +- src/simulation/m_ib_patches.fpp | 22 +-- src/simulation/m_ibm.fpp | 22 +-- src/simulation/m_igr.fpp | 24 ++-- src/simulation/m_mpi_proxy.fpp | 8 +- src/simulation/m_muscl.fpp | 6 +- src/simulation/m_pressure_relaxation.fpp | 1 + src/simulation/m_qbmm.fpp | 80 +++++------ src/simulation/m_rhs.fpp | 48 +++---- src/simulation/m_riemann_solvers.fpp | 44 +++--- src/simulation/m_sim_helpers.fpp | 28 ++-- src/simulation/m_start_up.fpp | 10 +- src/simulation/m_surface_tension.fpp | 18 +-- src/simulation/m_time_steppers.fpp | 20 +-- src/simulation/m_viscous.fpp | 55 ++++---- src/simulation/m_weno.fpp | 56 ++++---- 59 files changed, 971 insertions(+), 1050 deletions(-) diff --git a/.ffmt.toml b/.ffmt.toml index 0060131b17..ffeaae969d 100644 --- a/.ffmt.toml +++ b/.ffmt.toml @@ -15,3 +15,4 @@ power = false assignment = true declaration = true comma = true +slice-colon = false diff --git a/src/common/include/3dHardcodedIC.fpp b/src/common/include/3dHardcodedIC.fpp index e599303463..ec63047d72 100644 --- a/src/common/include/3dHardcodedIC.fpp +++ b/src/common/include/3dHardcodedIC.fpp @@ -6,14 +6,14 @@ ! IGR Jets Arrays to stor position and radii of jets from input file real(wp), dimension(:), allocatable :: y_th_arr, z_th_arr, r_th_arr ! Variables to describe initial condition of jet - real(wp) :: r, ux_th, ux_am, p_th, p_am, rho_th, rho_am, y_th, z_th, r_th, eps_smooth - real(wp) :: rcut, xcut ! Intermediate variables for creating smooth initial condition - real(wp), dimension(0:n, 0:p) :: rcut_arr - integer :: l, q, s ! Iterators for reading input files - integer :: start, end ! Ints to keep track of position in file - character(len=1000) :: line ! String to store line in file - character(len=25) :: value ! String to store value in line - integer :: NJet ! Number of jets + real(wp) :: r, ux_th, ux_am, p_th, p_am, rho_th, rho_am, y_th, z_th, r_th, eps_smooth + real(wp) :: rcut, xcut !< Intermediate variables for creating smooth initial condition + real(wp), dimension(0:n,0:p) :: rcut_arr + integer :: l, q, s !< Iterators for reading input files + integer :: start, end !< Ints to keep track of position in file + character(len=1000) :: line !< String to store line in file + character(len=25) :: value !< String to store value in line + integer :: NJet !< Number of jets eps = 1e-9_wp diff --git a/src/common/include/ExtrusionHardcodedIC.fpp b/src/common/include/ExtrusionHardcodedIC.fpp index b5e8b379da..07acc54a5e 100644 --- a/src/common/include/ExtrusionHardcodedIC.fpp +++ b/src/common/include/ExtrusionHardcodedIC.fpp @@ -40,18 +40,18 @@ integer :: f, iter, ios, ios2, unit, unit2, idx, idy, index_x, index_y, jump, line_count, ycount real(wp) :: x_len, x_step, y_len, y_step real(wp) :: dummy_x, dummy_y, dummy_z, x0, y0 - integer :: global_offset_x, global_offset_y ! MPI subdomain offset + integer :: global_offset_x, global_offset_y !< MPI subdomain offset real(wp) :: delta_x, delta_y - character(len=100), dimension(sys_size) :: fileNames ! Arrays to store all data from files + character(len=100), dimension(sys_size) :: fileNames !< Arrays to store all data from files character(len=200) :: errmsg real(wp), allocatable :: stored_values(:,:,:) real(wp), allocatable :: x_coords(:), y_coords(:) logical :: files_loaded = .false. real(wp) :: domain_xstart, domain_xend, domain_ystart, domain_yend - character(len=*), parameter :: init_dir = "/home/MFC/FilesDirectory" ! For example /home/MFC/examples/1D_Shock/D/ - character(len=20) :: file_num_str ! For storing the file number as a string - character(len=20) :: zeros_part ! For the trailing zeros part - character(len=6), parameter :: zeros_default = "000000" ! Default zeros (can be changed) + character(len=*), parameter :: init_dir = "/home/MFC/FilesDirectory" !< For example /home/MFC/examples/1D_Shock/D/ + character(len=20) :: file_num_str !< For storing the file number as a string + character(len=20) :: zeros_part !< For the trailing zeros part + character(len=6), parameter :: zeros_default = "000000" !< Default zeros (can be changed) #:enddef #:def HardcodedReadValues() diff --git a/src/common/m_boundary_common.fpp b/src/common/m_boundary_common.fpp index 33dd8dff2c..918b0daea5 100644 --- a/src/common/m_boundary_common.fpp +++ b/src/common/m_boundary_common.fpp @@ -21,8 +21,8 @@ module m_boundary_common $:GPU_DECLARE(create='[bc_buffers]') #ifdef MFC_MPI - integer, dimension(1:3, 1:2) :: MPI_BC_TYPE_TYPE - integer, dimension(1:3, 1:2) :: MPI_BC_BUFFER_TYPE + integer, dimension(1:3,1:2) :: MPI_BC_TYPE_TYPE + integer, dimension(1:3,1:2) :: MPI_BC_BUFFER_TYPE #endif private; public :: s_initialize_boundary_common_module, s_populate_variables_buffers, s_create_mpi_types, & @@ -73,10 +73,10 @@ contains !> Populate the buffers of the primitive variables based on the selected boundary conditions. impure subroutine s_populate_variables_buffers(bc_type, q_prim_vf, pb_in, mv_in) - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - integer :: k, l + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + integer :: k, l ! BC type codes defined in m_constants.fpp; non-negative values are MPI boundaries @@ -330,11 +330,11 @@ contains subroutine s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - integer :: j, q, i + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, q, i if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then !< bc_x%beg @@ -553,11 +553,11 @@ contains subroutine s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - integer :: j, q, i + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, q, i if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then !< bc_x%beg @@ -675,10 +675,10 @@ contains subroutine s_axis(q_prim_vf, pb_in, mv_in, k, l) $:GPU_ROUTINE(parallelism='[seq]') - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: k, l - integer :: j, q, i + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in + integer, intent(in) :: k, l + integer :: j, q, i do j = 1, buff_size if (z_cc(l) < pi) then @@ -971,10 +971,10 @@ contains subroutine s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in) $:GPU_ROUTINE(parallelism='[seq]') - real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in - integer, intent(in) :: bc_dir, bc_loc - integer, intent(in) :: k, l - integer :: j, q, i + real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in + integer, intent(in) :: bc_dir, bc_loc + integer, intent(in) :: k, l + integer :: j, q, i if (bc_dir == 1) then !< x-direction if (bc_loc == -1) then ! bc_x%beg @@ -1043,9 +1043,9 @@ contains !> Populate ghost cell buffers for the color function and its divergence used in capillary surface tension. impure subroutine s_populate_capillary_buffers(c_divs, bc_type) - type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - integer :: k, l + type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + integer :: k, l !> x-direction @@ -1367,9 +1367,9 @@ contains !> Populate ghost cell buffers for the Jacobian scalar field used in the IGR elliptic solver. impure subroutine s_populate_F_igr_buffers(bc_type, jac_sf) - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - type(scalar_field), dimension(1:), intent(inout) :: jac_sf - integer :: j, k, l + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + type(scalar_field), dimension(1:), intent(inout) :: jac_sf + integer :: j, k, l if (bc_x%beg >= 0) then call s_mpi_sendrecv_variables_buffers(jac_sf, 1, -1, 1) @@ -1534,7 +1534,7 @@ contains !> Create MPI derived datatypes for boundary condition type arrays and buffer arrays used in parallel I/O. impure subroutine s_create_mpi_types(bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type #ifdef MFC_MPI integer :: dir, loc @@ -1569,13 +1569,13 @@ contains !> Write boundary condition type and buffer data to serial (unformatted) restart files. subroutine s_write_serial_boundary_condition_files(q_prim_vf, bc_type, step_dirpath, old_grid_in) - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - logical, intent(in) :: old_grid_in - character(LEN=*), intent(in) :: step_dirpath - integer :: dir, loc, i - character(len=path_len) :: file_path - character(len=10) :: status + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + logical, intent(in) :: old_grid_in + character(LEN=*), intent(in) :: step_dirpath + integer :: dir, loc, i + character(len=path_len) :: file_path + character(len=10) :: status if (old_grid_in) then status = 'old' @@ -1608,11 +1608,11 @@ contains !> Write boundary condition type and buffer data to per-rank parallel files using MPI I/O. subroutine s_write_parallel_boundary_condition_files(q_prim_vf, bc_type) - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - integer :: dir, loc - character(len=path_len) :: file_loc, file_path - character(len=10) :: status + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + integer :: dir, loc + character(len=path_len) :: file_loc, file_path + character(len=10) :: status #ifdef MFC_MPI integer :: ierr @@ -1673,12 +1673,12 @@ contains !> Read boundary condition type and buffer data from serial (unformatted) restart files. subroutine s_read_serial_boundary_condition_files(step_dirpath, bc_type) - character(LEN=*), intent(in) :: step_dirpath - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - integer :: dir, loc - logical :: file_exist - character(len=path_len) :: file_path - character(len=10) :: status + character(LEN=*), intent(in) :: step_dirpath + type(integer_field), dimension(1:num_dims,1:2), intent(inout) :: bc_type + integer :: dir, loc + logical :: file_exist + character(len=path_len) :: file_path + character(len=10) :: status ! Read bc_types @@ -1718,10 +1718,10 @@ contains !> Read boundary condition type and buffer data from per-rank parallel files using MPI I/O. subroutine s_read_parallel_boundary_condition_files(bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - integer :: dir, loc - character(len=path_len) :: file_loc, file_path - character(len=10) :: status + type(integer_field), dimension(1:num_dims,1:2), intent(inout) :: bc_type + integer :: dir, loc + character(len=path_len) :: file_loc, file_path + character(len=10) :: status #ifdef MFC_MPI integer :: ierr @@ -1826,7 +1826,7 @@ contains !> Initialize the per-cell boundary condition type arrays with the global default BC values. subroutine s_assign_default_bc_type(bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type bc_type(1, 1)%sf(:,:,:) = int(min(bc_x%beg, 0), kind=1) bc_type(1, 2)%sf(:,:,:) = int(min(bc_x%end, 0), kind=1) diff --git a/src/common/m_constants.fpp b/src/common/m_constants.fpp index 789a5960eb..8e01059691 100644 --- a/src/common/m_constants.fpp +++ b/src/common/m_constants.fpp @@ -50,7 +50,7 @@ module m_constants real(wp), parameter :: dflt_ic_beta = 1.6_wp !< Sharpness parameter's default value used in THINC real(wp), parameter :: moncon_cutoff = 1e-8_wp !< Monotonicity constraint's limiter to prevent extremas in THINC ! Chemistry - real(wp), parameter :: dflt_T_guess = 1200._wp ! Default guess for temperature (when a previous value is not available) + real(wp), parameter :: dflt_T_guess = 1200._wp !< Default guess for temperature (when a previous value is not available) ! IBM+STL interpolation constants integer, parameter :: num_ray = 20 !< Default number of rays traced per cell @@ -61,7 +61,7 @@ module m_constants ! Lagrange bubbles constants integer, parameter :: mapCells = 3 !< Number of cells around the bubble where the smoothening function will have effect real(wp), parameter :: R_uni = 8314._wp !< Universal gas constant - J/kmol/K - integer, parameter :: lag_io_vars = 21 ! Number of variables per particle for MPI_IO + integer, parameter :: lag_io_vars = 21 !< Number of variables per particle for MPI_IO ! Strang Splitting constants real(wp), parameter :: dflt_adap_dt_tol = 1.e-4_wp !< Default tolerance for adaptive step size diff --git a/src/common/m_delay_file_access.f90 b/src/common/m_delay_file_access.f90 index 48f888ab06..0f154af46c 100644 --- a/src/common/m_delay_file_access.f90 +++ b/src/common/m_delay_file_access.f90 @@ -6,7 +6,9 @@ module m_delay_file_access use m_precision_select + implicit none + private public :: DelayFileAccess diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index d5180d389a..0c00de90d7 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -147,8 +147,8 @@ module m_derived_types end type ic_model_parameters type :: t_triangle - real(wp), dimension(1:3, 1:3) :: v !< Vertices of the triangle - real(wp), dimension(1:3) :: n !< Normal vector + real(wp), dimension(1:3,1:3) :: v !< Vertices of the triangle + real(wp), dimension(1:3) :: n !< Normal vector end type t_triangle type :: t_ray @@ -187,14 +187,10 @@ module m_derived_types type ic_patch_parameters integer :: geometry !< Type of geometry for the patch - !> Location of the geometric center, i.e. the centroid, of the patch. It is specified through its x-, y- and z-coordinates, - !! respectively. - real(wp) :: x_centroid, y_centroid, z_centroid + real(wp) :: x_centroid, y_centroid, z_centroid !< Geometric center coordinates of the patch real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. - !> Vector indicating the various radii for the elliptical and ellipsoidal patch geometries. It is specified through its x-, - !! y-, and z-components respectively. - real(wp), dimension(3) :: radii + real(wp) :: radius !< Dimensions of the patch. radius. + real(wp), dimension(3) :: radii !< Elliptical/ellipsoidal patch radii in x, y, z real(wp) :: epsilon, beta !< The isentropic vortex parameters for the amplitude of the disturbance and domain of influence. real(wp), dimension(2:9) :: a !< Used by hardcoded IC and as temporary variables. logical :: non_axis_sym @@ -205,84 +201,76 @@ module m_derived_types real(wp) :: modal_r_min !< Minimum boundary radius when modal_clip_r_to_min is true (Non-exp form only) logical :: modal_use_exp_form !< When true, boundary = radius*exp(Fourier series) ! Geometry 14 (3D spherical harmonic): sph_har_coeff(l,m) for real Y_lm - real(wp), dimension(0:max_sph_harm_degree, -max_sph_harm_degree:max_sph_harm_degree) :: sph_har_coeff - !> Normal vector indicating the orientation of the patch. It is specified through its x-, y- and z-components, respectively. - real(wp), dimension(3) :: normal - !> List of permissions that indicate to the current patch which preceding patches it is allowed to overwrite when it is in - !! process of being laid out in the domain - logical, dimension(0:num_patches_max - 1) :: alter_patch - !> Permission indicating to the current patch whether its boundaries will be smoothed out across a few cells or whether they - !! are to remain sharp - logical :: smoothen + real(wp), dimension(0:max_sph_harm_degree,-max_sph_harm_degree:max_sph_harm_degree) :: sph_har_coeff + real(wp), dimension(3) :: normal !< Patch orientation normal vector (x, y, z) + logical, dimension(0:num_patches_max - 1) :: alter_patch !< Overwrite permissions for preceding patches + logical :: smoothen !< Whether patch boundaries are smoothed across cells integer :: smooth_patch_id !< Identity (id) of the patch with which current patch is to get smoothed - !> Smoothing coefficient (coeff) for the size of the stencil of cells across which boundaries of the current patch will be - !! smeared out - real(wp) :: smooth_coeff + real(wp) :: smooth_coeff !< Smoothing stencil size coefficient real(wp), dimension(num_fluids_max) :: alpha_rho - real(wp) :: rho - real(wp), dimension(3) :: vel - real(wp) :: pres + real(wp) :: rho + real(wp), dimension(3) :: vel + real(wp) :: pres real(wp), dimension(num_fluids_max) :: alpha - real(wp) :: gamma - real(wp) :: pi_inf - real(wp) :: cv - real(wp) :: qv - !> Primitive variables associated with the patch. In order, these include the partial densities, density, velocity, - !! pressure, volume fractions, specific heat ratio function and the liquid stiffness function. - real(wp) :: qvp - real(wp) :: Bx, By, Bz !< Magnetic field components; B%x is not used for 1D - real(wp), dimension(6) :: tau_e !< Elastic stresses added to primitive variables if hypoelasticity = True - real(wp) :: R0 !< Bubble size - real(wp) :: V0 !< Bubble velocity - real(wp) :: p0 !< Bubble size - real(wp) :: m0 !< Bubble velocity - integer :: hcid !< Hardcoded initial condition ID - real(wp) :: cf_val !< Color function value - real(wp) :: Y(1:num_species) !< Species mass fractions + real(wp) :: gamma + real(wp) :: pi_inf + real(wp) :: cv + real(wp) :: qv + real(wp) :: qvp !< Reference entropy per unit mass (SGEOS) + real(wp) :: Bx, By, Bz !< Magnetic field components; B%x is not used for 1D + real(wp), dimension(6) :: tau_e !< Elastic stresses added to primitive variables if hypoelasticity = True + real(wp) :: R0 !< Bubble size + real(wp) :: V0 !< Bubble velocity + real(wp) :: p0 !< Bubble size + real(wp) :: m0 !< Bubble velocity + integer :: hcid !< Hardcoded initial condition ID + real(wp) :: cf_val !< Color function value + real(wp) :: Y(1:num_species) !< Species mass fractions ! STL or OBJ model input parameter - character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. - real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. - real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. - real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. - integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. - real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. + character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. + real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. + real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. + !> Angle to rotate the STL object along each cartesian coordinate axis, in radians. + real(wp), dimension(1:3) :: model_rotate + integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. + real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. end type ic_patch_parameters type ib_patch_parameters - integer :: geometry !< Type of geometry for the patch - !> Location of the geometric center, i.e. the centroid, of the patch. It is specified through its x-, y- and z-coordinates, - !! respectively. - real(wp) :: x_centroid, y_centroid, z_centroid + integer :: geometry !< Type of geometry for the patch + real(wp) :: x_centroid, y_centroid, z_centroid !< Geometric center coordinates of the patch !> Centroid locations of intermediate steps in the time_stepper module - real(wp) :: step_x_centroid, step_y_centroid, step_z_centroid - real(wp), dimension(1:3) :: centroid_offset ! offset of center of mass from computed cell center for odd-shaped IBs - real(wp), dimension(1:3) :: angles - real(wp), dimension(1:3) :: step_angles - real(wp), dimension(1:3, 1:3) :: rotation_matrix !< matrix that converts from IB reference frame to fluid reference frame + real(wp) :: step_x_centroid, step_y_centroid, step_z_centroid + real(wp), dimension(1:3) :: centroid_offset !< offset of center of mass from computed cell center for odd-shaped IBs + real(wp), dimension(1:3) :: angles + real(wp), dimension(1:3) :: step_angles + !> matrix that converts from IB reference frame to fluid reference frame + real(wp), dimension(1:3,1:3) :: rotation_matrix !> matrix that converts from fluid reference frame to IB reference frame - real(wp), dimension(1:3, 1:3) :: rotation_matrix_inverse - real(wp) :: c, p, t, m - real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. - real(wp) :: radius !< Dimensions of the patch. radius. - real(wp) :: theta - logical :: slip + real(wp), dimension(1:3,1:3) :: rotation_matrix_inverse + real(wp) :: c, p, t, m + real(wp) :: length_x, length_y, length_z !< Dimensions of the patch. x,y,z Lengths. + real(wp) :: radius !< Dimensions of the patch. radius. + real(wp) :: theta + logical :: slip ! STL or OBJ model input parameter - character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. - real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. - real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. - real(wp), dimension(1:3) :: model_rotate !< Angle to rotate the STL object along each cartesian coordinate axis, in radians. + character(LEN=pathlen_max) :: model_filepath !< Path the STL file relative to case_dir. + real(wp), dimension(1:3) :: model_translate !< Translation of the STL object. + real(wp), dimension(1:3) :: model_scale !< Scale factor for the STL object. + !> Angle to rotate the STL object along each cartesian coordinate axis, in radians. + real(wp), dimension(1:3) :: model_rotate integer :: model_spc !< Number of samples per cell to use when discretizing the STL object. real(wp) :: model_threshold !< Threshold to turn on smoothen STL patch. Patch conditions for moving imersed boundaries - integer :: moving_ibm ! 0 for no moving, 1 for moving, 2 for moving on forced path - real(wp) :: mass, moment ! mass and moment of inertia of object used to compute forces in 2-way coupling - real(wp), dimension(1:3) :: force, torque ! vectors for the computed force and torque values applied to an IB + integer :: moving_ibm !< 0 for no moving, 1 for moving, 2 for moving on forced path + real(wp) :: mass, moment !< mass and moment of inertia of object used to compute forces in 2-way coupling + real(wp), dimension(1:3) :: force, torque !< vectors for the computed force and torque values applied to an IB real(wp), dimension(1:3) :: vel - real(wp), dimension(1:3) :: step_vel ! velocity array used to store intermediate steps in the time_stepper module + real(wp), dimension(1:3) :: step_vel !< velocity array used to store intermediate steps in the time_stepper module real(wp), dimension(1:3) :: angular_vel - real(wp), dimension(1:3) :: step_angular_vel ! velocity array used to store intermediate steps in the time_stepper module + real(wp), dimension(1:3) :: step_angular_vel !< velocity array used to store intermediate steps in the time_stepper module end type ib_patch_parameters !> Derived type annexing the physical parameters (PP) of the fluids. These include the specific heat ratio function and liquid @@ -352,8 +340,8 @@ module m_derived_types real(wp) :: npulse !< Number of cycles of pulse real(wp) :: dir !< Direction of pulse real(wp) :: delay !< Time-delay of pulse start - real(wp) :: foc_length ! < Focal length of transducer - real(wp) :: aperture ! < Aperture diameter of transducer + real(wp) :: foc_length !< Focal length of transducer + real(wp) :: aperture !< Aperture diameter of transducer real(wp) :: element_spacing_angle !< Spacing between aperture elements in 2D acoustic array !> Ratio of aperture element diameter to side length of polygon connecting their centers, in 3D acoustic array real(wp) :: element_polygon_ratio @@ -429,13 +417,13 @@ module m_derived_types end type cell_num_bounds type simplex_noise_params - logical, dimension(3) :: perturb_vel - real(wp), dimension(3) :: perturb_vel_freq - real(wp), dimension(3) :: perturb_vel_scale - real(wp), dimension(3, 3) :: perturb_vel_offset - logical, dimension(1:num_fluids_max) :: perturb_dens - real(wp), dimension(1:num_fluids_max) :: perturb_dens_freq - real(wp), dimension(1:num_fluids_max) :: perturb_dens_scale - real(wp), dimension(1:num_fluids_max, 3) :: perturb_dens_offset + logical, dimension(3) :: perturb_vel + real(wp), dimension(3) :: perturb_vel_freq + real(wp), dimension(3) :: perturb_vel_scale + real(wp), dimension(3, 3) :: perturb_vel_offset + logical, dimension(1:num_fluids_max) :: perturb_dens + real(wp), dimension(1:num_fluids_max) :: perturb_dens_freq + real(wp), dimension(1:num_fluids_max) :: perturb_dens_scale + real(wp), dimension(1:num_fluids_max,3) :: perturb_dens_offset end type simplex_noise_params end module m_derived_types diff --git a/src/common/m_finite_differences.fpp b/src/common/m_finite_differences.fpp index efa4a2375e..f26c203dcd 100644 --- a/src/common/m_finite_differences.fpp +++ b/src/common/m_finite_differences.fpp @@ -96,7 +96,7 @@ contains #ifdef MFC_POST_PROCESS if (allocated(fd_coeff_s)) deallocate (fd_coeff_s) - allocate (fd_coeff_s(-fd_number_in:fd_number_in, lb:lE)) + allocate (fd_coeff_s(-fd_number_in:fd_number_in,lb:lE)) #endif ! Computing the 1st order finite-difference coefficients diff --git a/src/common/m_helper.fpp b/src/common/m_helper.fpp index b519ffb856..4074530a8f 100644 --- a/src/common/m_helper.fpp +++ b/src/common/m_helper.fpp @@ -11,6 +11,7 @@ module m_helper use m_derived_types use m_global_parameters use ieee_arithmetic !< For checking NaN + implicit none private @@ -313,7 +314,7 @@ contains type(ic_model_parameters), intent(in) :: param real(wp), dimension(1:3), optional, intent(in) :: center - real(wp), dimension(1:4, 1:4) :: sc, rz, rx, ry, tr, t_back, t_to_origin, out_matrix + real(wp), dimension(1:4,1:4) :: sc, rz, rx, ry, tr, t_back, t_to_origin, out_matrix sc = transpose(reshape([param%scale(1), 0._wp, 0._wp, 0._wp, 0._wp, param%scale(2), 0._wp, 0._wp, 0._wp, 0._wp, & & param%scale(3), 0._wp, 0._wp, 0._wp, 0._wp, 1._wp], shape(sc))) @@ -349,9 +350,9 @@ contains !> Transform a vector by a matrix. subroutine s_transform_vec(vec, matrix) - real(wp), dimension(1:3), intent(inout) :: vec - real(wp), dimension(1:4, 1:4), intent(in) :: matrix - real(wp), dimension(1:4) :: tmp + real(wp), dimension(1:3), intent(inout) :: vec + real(wp), dimension(1:4,1:4), intent(in) :: matrix + real(wp), dimension(1:4) :: tmp tmp = matmul(matrix, [vec(1), vec(2), vec(3), 1._wp]) vec = tmp(1:3) @@ -361,9 +362,9 @@ contains !> Transform a triangle by a matrix, one vertex at a time. subroutine s_transform_triangle(triangle, matrix, matrix_n) - type(t_triangle), intent(inout) :: triangle - real(wp), dimension(1:4, 1:4), intent(in) :: matrix, matrix_n - integer :: i + type(t_triangle), intent(inout) :: triangle + real(wp), dimension(1:4,1:4), intent(in) :: matrix, matrix_n + integer :: i do i = 1, 3 call s_transform_vec(triangle%v(i,:), matrix) @@ -376,9 +377,9 @@ contains !> Transform a model by a matrix, one triangle at a time. subroutine s_transform_model(model, matrix, matrix_n) - type(t_model), intent(inout) :: model - real(wp), dimension(1:4, 1:4), intent(in) :: matrix, matrix_n - integer :: i + type(t_model), intent(inout) :: model + real(wp), dimension(1:4,1:4), intent(in) :: matrix, matrix_n + integer :: i do i = 1, size(model%trs) call s_transform_triangle(model%trs(i), matrix, matrix_n) @@ -505,7 +506,7 @@ contains elemental function double_factorial(n_in) result(R_result) integer, intent(in) :: n_in - integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer + integer, parameter :: int64_kind = selected_int_kind(18) !< 18 bytes for 64-bit integer integer(kind=int64_kind) :: R_result integer :: i @@ -517,7 +518,7 @@ contains elemental function factorial(n_in) result(R_result) integer, intent(in) :: n_in - integer, parameter :: int64_kind = selected_int_kind(18) ! 18 bytes for 64-bit integer + integer, parameter :: int64_kind = selected_int_kind(18) !< 18 bytes for 64-bit integer integer(kind=int64_kind) :: R_result integer :: i diff --git a/src/common/m_helper_basic.fpp b/src/common/m_helper_basic.fpp index 7567bc6c6f..7208a451da 100644 --- a/src/common/m_helper_basic.fpp +++ b/src/common/m_helper_basic.fpp @@ -8,6 +8,7 @@ module m_helper_basic use m_derived_types + implicit none private diff --git a/src/common/m_model.fpp b/src/common/m_model.fpp index ece301311f..c88bffa7e6 100644 --- a/src/common/m_model.fpp +++ b/src/common/m_model.fpp @@ -252,7 +252,7 @@ contains rewind (iunit) - allocate (vertices(nVertices, 1:3)) + allocate (vertices(nVertices,1:3)) allocate (model%trs(model%ntrs)) i = 1 @@ -493,7 +493,7 @@ contains real(wp) :: fraction type(t_ray) :: ray integer :: i, j, k, nInOrOut, nHits - real(wp), dimension(1:spc, 1:3) :: ray_origins, ray_dirs + real(wp), dimension(1:spc,1:3) :: ray_origins, ray_dirs rand_seed = int(point(1)*73856093._wp) + int(point(2)*19349663._wp) + int(point(3)*83492791._wp) if (rand_seed == 0) rand_seed = 1 @@ -569,9 +569,9 @@ contains else ! 3D winding number: sum solid angles via Van Oosterom-Strackee formula. do q = 1, ntrs - r1 = gpu_trs_v(1,:, q, pid) - point - r2 = gpu_trs_v(2,:, q, pid) - point - r3 = gpu_trs_v(3,:, q, pid) - point + r1 = gpu_trs_v(1,:,q, pid) - point + r2 = gpu_trs_v(2,:,q, pid) - point + r3 = gpu_trs_v(3,:,q, pid) - point r1_mag = sqrt(dot_product(r1, r1)) r2_mag = sqrt(dot_product(r2, r2)) @@ -644,9 +644,9 @@ contains integer, intent(out) :: boundary_vertex_count, boundary_edge_count !< Output boundary vertex/edge count integer :: i, j !< Model index iterator integer :: edge_count, edge_index, store_index !< Boundary edge index iterator - real(wp), dimension(1:2, 1:2) :: edge !< Edge end points buffer + real(wp), dimension(1:2,1:2) :: edge !< Edge end points buffer real(wp), dimension(1:2) :: boundary_edge !< Boundary edge end points buffer - real(wp), dimension(1:(3*model%ntrs), 1:2, 1:2) :: temp_boundary_v !< Temporary boundary vertex buffer + real(wp), dimension(1:(3*model%ntrs),1:2,1:2) :: temp_boundary_v !< Temporary boundary vertex buffer integer, dimension(1:(3*model%ntrs)) :: edge_occurrence !< The manifoldness of the edges real(wp) :: edgetan, initial, v_norm, xnormal, ynormal !< The manifoldness of the edges ! Total number of edges in 2D STL @@ -660,18 +660,18 @@ contains ! Collect all edges of all triangles and store them do i = 1, model%ntrs ! First edge (v1, v2) - edge(1, 1:2) = model%trs(i)%v(1, 1:2) - edge(2, 1:2) = model%trs(i)%v(2, 1:2) + edge(1,1:2) = model%trs(i)%v(1,1:2) + edge(2,1:2) = model%trs(i)%v(2,1:2) call s_register_edge(temp_boundary_v, edge, edge_index, edge_count) ! Second edge (v2, v3) - edge(1, 1:2) = model%trs(i)%v(2, 1:2) - edge(2, 1:2) = model%trs(i)%v(3, 1:2) + edge(1,1:2) = model%trs(i)%v(2,1:2) + edge(2,1:2) = model%trs(i)%v(3,1:2) call s_register_edge(temp_boundary_v, edge, edge_index, edge_count) ! Third edge (v3, v1) - edge(1, 1:2) = model%trs(i)%v(3, 1:2) - edge(2, 1:2) = model%trs(i)%v(1, 1:2) + edge(1,1:2) = model%trs(i)%v(3,1:2) + edge(2,1:2) = model%trs(i)%v(1,1:2) call s_register_edge(temp_boundary_v, edge, edge_index, edge_count) end do @@ -709,15 +709,15 @@ contains end do ! Allocate the boundary_v array based on the number of boundary edges - allocate (boundary_v(boundary_edge_count, 1:3, 1:2)) + allocate (boundary_v(boundary_edge_count,1:3,1:2)) ! Store boundary vertices store_index = 0 do i = 1, edge_count if (edge_occurrence(i) == 0) then store_index = store_index + 1 - boundary_v(store_index, 1, 1:2) = temp_boundary_v(i, 1, 1:2) - boundary_v(store_index, 2, 1:2) = temp_boundary_v(i, 2, 1:2) + boundary_v(store_index, 1,1:2) = temp_boundary_v(i, 1,1:2) + boundary_v(store_index, 2,1:2) = temp_boundary_v(i, 2,1:2) end if end do @@ -751,15 +751,15 @@ contains !> Append the edge end vertices to a temporary buffer. subroutine s_register_edge(temp_boundary_v, edge, edge_index, edge_count) - integer, intent(inout) :: edge_index !< Edge index iterator - integer, intent(inout) :: edge_count !< Total number of edges - real(wp), intent(in), dimension(1:2, 1:2) :: edge !< Edges end points to be registered - real(wp), dimension(1:edge_count, 1:2, 1:2), intent(inout) :: temp_boundary_v !< Temporary edge end vertex buffer + integer, intent(inout) :: edge_index !< Edge index iterator + integer, intent(inout) :: edge_count !< Total number of edges + real(wp), intent(in), dimension(1:2,1:2) :: edge !< Edges end points to be registered + real(wp), dimension(1:edge_count,1:2,1:2), intent(inout) :: temp_boundary_v !< Temporary edge end vertex buffer ! Increment edge index and store the edge edge_index = edge_index + 1 - temp_boundary_v(edge_index, 1, 1:2) = edge(1, 1:2) - temp_boundary_v(edge_index, 2, 1:2) = edge(2, 1:2) + temp_boundary_v(edge_index, 1,1:2) = edge(1,1:2) + temp_boundary_v(edge_index, 2,1:2) = edge(2,1:2) end subroutine s_register_edge @@ -783,19 +783,19 @@ contains real(wp) :: u, v_bary, w real(wp) :: l00, l01, l11, l20, l21 real(wp) :: edge(1:3), pe(1:3) - real(wp) :: verts(1:3, 1:3) + real(wp) :: verts(1:3,1:3) dist_min = initial_distance_buffer normals = 0._wp do i = 1, ntrs ! Triangle vertices - v1(:) = gpu_trs_v(1,:, i, pid) - v2(:) = gpu_trs_v(2,:, i, pid) - v3(:) = gpu_trs_v(3,:, i, pid) + v1(:) = gpu_trs_v(1,:,i, pid) + v2(:) = gpu_trs_v(2,:,i, pid) + v3(:) = gpu_trs_v(3,:,i, pid) ! Triangle normal - n(:) = gpu_trs_n(:, i, pid) + n(:) = gpu_trs_n(:,i, pid) ! Project point onto triangle plane pv(:) = point(:) - v1(:) @@ -837,19 +837,19 @@ contains end if else ! Projection outside triangle: check edges and vertices - verts(:, 1) = v1(:) - verts(:, 2) = v2(:) - verts(:, 3) = v3(:) + verts(:,1) = v1(:) + verts(:,2) = v2(:) + verts(:,3) = v3(:) ! Check three edges do j = 1, 3 - edge(:) = verts(:, mod(j, 3) + 1) - verts(:, j) - pe(:) = point(:) - verts(:, j) + edge(:) = verts(:,mod(j, 3) + 1) - verts(:,j) + pe(:) = point(:) - verts(:,j) t = dot_product(pe, edge)/max(dot_product(edge, edge), 1.e-30_wp) if (t >= 0._wp .and. t <= 1._wp) then - proj(:) = verts(:, j) + t*edge(:) + proj(:) = verts(:,j) + t*edge(:) dist_e = sqrt((point(1) - proj(1))**2 + (point(2) - proj(2))**2 + (point(3) - proj(3))**2) if (dist_e < dist_min) then @@ -868,7 +868,7 @@ contains if (dist_v < dist_min) then dist_min = dist_v - norm_vec(:) = verts(:, j) - point(:) + norm_vec(:) = verts(:,j) - point(:) norm_mag = sqrt(dot_product(norm_vec, norm_vec)) if (norm_mag > 0._wp) norm_vec = norm_vec/norm_mag normals(:) = norm_vec(:) @@ -879,7 +879,7 @@ contains if (dist_v < dist_min) then dist_min = dist_v - norm_vec(:) = verts(:, mod(j, 3) + 1) - point(:) + norm_vec(:) = verts(:,mod(j, 3) + 1) - point(:) norm_mag = sqrt(dot_product(norm_vec, norm_vec)) if (norm_mag > 0._wp) norm_vec = norm_vec/norm_mag normals(:) = norm_vec(:) @@ -978,13 +978,13 @@ contains type(ic_model_parameters) :: params real(wp) :: eta real(wp), dimension(1:3) :: point, model_center - real(wp) :: grid_mm(1:3, 1:2) - real(wp), dimension(1:4, 1:4) :: transform, transform_n + real(wp) :: grid_mm(1:3,1:2) + real(wp), dimension(1:4,1:4) :: transform, transform_n dx_local = minval(dx); dy_local = minval(dy) if (p /= 0) dz_local = minval(dz) - allocate (stl_bounding_boxes(num_ibs, 1:3, 1:3)) + allocate (stl_bounding_boxes(num_ibs,1:3,1:3)) do patch_id = 1, num_ibs if (patch_ib(patch_id)%geometry == 5 .or. patch_ib(patch_id)%geometry == 12) then @@ -1046,14 +1046,14 @@ contains grid_mm(3,:) = (/0._wp, 0._wp/) end if - write (*, "(A, 3(2X, F20.10))") " > Domain: Min:", grid_mm(:, 1) - write (*, "(A, 3(2X, F20.10))") " > Cen:", (grid_mm(:, 1) + grid_mm(:, 2))/2._wp - write (*, "(A, 3(2X, F20.10))") " > Max:", grid_mm(:, 2) + write (*, "(A, 3(2X, F20.10))") " > Domain: Min:", grid_mm(:,1) + write (*, "(A, 3(2X, F20.10))") " > Cen:", (grid_mm(:,1) + grid_mm(:,2))/2._wp + write (*, "(A, 3(2X, F20.10))") " > Max:", grid_mm(:,2) end if - stl_bounding_boxes(patch_id, 1, 1:3) = [bbox%min(1), (bbox%min(1) + bbox%max(1))/2._wp, bbox%max(1)] - stl_bounding_boxes(patch_id, 2, 1:3) = [bbox%min(2), (bbox%min(2) + bbox%max(2))/2._wp, bbox%max(2)] - stl_bounding_boxes(patch_id, 3, 1:3) = [bbox%min(3), (bbox%min(3) + bbox%max(3))/2._wp, bbox%max(3)] + stl_bounding_boxes(patch_id, 1,1:3) = [bbox%min(1), (bbox%min(1) + bbox%max(1))/2._wp, bbox%max(1)] + stl_bounding_boxes(patch_id, 2,1:3) = [bbox%min(2), (bbox%min(2) + bbox%max(2))/2._wp, bbox%max(2)] + stl_bounding_boxes(patch_id, 3,1:3) = [bbox%min(3), (bbox%min(3) + bbox%max(3))/2._wp, bbox%max(3)] models(patch_id)%model = model if (p == 0) then @@ -1105,14 +1105,14 @@ contains do pid = 1, num_ibs if (allocated(models(pid)%model)) then gpu_ntrs(pid) = models(pid)%ntrs - gpu_trs_v(:,:, 1:models(pid)%ntrs, pid) = models(pid)%trs_v - gpu_trs_n(:, 1:models(pid)%ntrs, pid) = models(pid)%trs_n + gpu_trs_v(:,:,1:models(pid)%ntrs,pid) = models(pid)%trs_v + gpu_trs_n(:,1:models(pid)%ntrs,pid) = models(pid)%trs_n gpu_boundary_edge_count(pid) = models(pid)%boundary_edge_count gpu_total_vertices(pid) = models(pid)%total_vertices end if if (allocated(models(pid)%boundary_v) .and. p == 0) then - gpu_boundary_v(1:size(models(pid)%boundary_v, 1), 1:size(models(pid)%boundary_v, 2), & - & 1:size(models(pid)%boundary_v, 3), pid) = models(pid)%boundary_v + gpu_boundary_v(1:size(models(pid)%boundary_v, 1),1:size(models(pid)%boundary_v, 2), & + & 1:size(models(pid)%boundary_v, 3),pid) = models(pid)%boundary_v end if end do @@ -1133,12 +1133,12 @@ contains integer :: i ma%ntrs = ma%model%ntrs - allocate (ma%trs_v(1:3, 1:3, 1:ma%ntrs)) - allocate (ma%trs_n(1:3, 1:ma%ntrs)) + allocate (ma%trs_v(1:3,1:3,1:ma%ntrs)) + allocate (ma%trs_n(1:3,1:ma%ntrs)) do i = 1, ma%ntrs - ma%trs_v(:,:, i) = ma%model%trs(i)%v(:,:) - ma%trs_n(:, i) = ma%model%trs(i)%n(:) + ma%trs_v(:,:,i) = ma%model%trs(i)%v(:,:) + ma%trs_n(:,i) = ma%model%trs(i)%n(:) end do end subroutine s_pack_model_for_gpu diff --git a/src/common/m_mpi_common.fpp b/src/common/m_mpi_common.fpp index 461fdb8a8e..8a719f5758 100644 --- a/src/common/m_mpi_common.fpp +++ b/src/common/m_mpi_common.fpp @@ -23,12 +23,8 @@ module m_mpi_common integer, private :: v_size $:GPU_DECLARE(create='[v_size]') - !> This variable is utilized to pack and send the buffer of the cell-average primitive variables, for a single computational - !! domain boundary at the time, to the relevant neighboring processor. - real(wp), private, allocatable, dimension(:) :: buff_send - !> buff_recv is utilized to receive and unpack the buffer of the cell- average primitive variables, for a single computational - !! domain boundary at the time, from the relevant neighboring processor. - real(wp), private, allocatable, dimension(:) :: buff_recv + real(wp), private, allocatable, dimension(:) :: buff_send !< Primitive variable send buffer for halo exchange + real(wp), private, allocatable, dimension(:) :: buff_recv !< Primitive variable receive buffer for halo exchange #ifndef __NVCOMPILER_GPU_UNIFIED_MEM $:GPU_DECLARE(create='[buff_send, buff_recv]') #endif @@ -119,11 +115,11 @@ contains end if do i = 1, sys_size - MPI_IO_DATA%var(i)%sf => q_cons_vf(i)%sf(0:m, 0:n, 0:p) + MPI_IO_DATA%var(i)%sf => q_cons_vf(i)%sf(0:m,0:n,0:p) end do if (present(beta)) then - MPI_IO_DATA%var(alt_sys)%sf => beta%sf(0:m, 0:n, 0:p) + MPI_IO_DATA%var(alt_sys)%sf => beta%sf(0:m,0:n,0:p) end if ! Additional variables pb and mv for non-polytropic qbmm @@ -131,11 +127,11 @@ contains do i = 1, nb do j = 1, nnode #ifdef MFC_PRE_PROCESS - MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j)%sf => pb%sf(0:m, 0:n, 0:p, j, i) - MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j + nb*nnode)%sf => mv%sf(0:m, 0:n, 0:p, j, i) + MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j)%sf => pb%sf(0:m,0:n,0:p,j, i) + MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j + nb*nnode)%sf => mv%sf(0:m,0:n,0:p,j, i) #elif defined (MFC_SIMULATION) - MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j)%sf => pb_ts(1)%sf(0:m, 0:n, 0:p, j, i) - MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j + nb*nnode)%sf => mv_ts(1)%sf(0:m, 0:n, 0:p, j, i) + MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j)%sf => pb_ts(1)%sf(0:m,0:n,0:p,j, i) + MPI_IO_DATA%var(sys_size + (i - 1)*nnode + j + nb*nnode)%sf => mv_ts(1)%sf(0:m,0:n,0:p,j, i) #endif end do end do @@ -169,7 +165,7 @@ contains #ifndef MFC_PRE_PROCESS if (present(ib_markers)) then - MPI_IO_IB_DATA%var%sf => ib_markers%sf(0:m, 0:n, 0:p) + MPI_IO_IB_DATA%var%sf => ib_markers%sf(0:m,0:n,0:p) call MPI_TYPE_CREATE_SUBARRAY(num_dims, sizes_glb, sizes_loc, start_idx, MPI_ORDER_FORTRAN, MPI_INTEGER, & & MPI_IO_IB_DATA%view, ierr) @@ -204,7 +200,7 @@ contains #ifdef MFC_POST_PROCESS do i = 1, sys_size - MPI_IO_DATA%var(i)%sf => q_cons_vf(i)%sf(-1:m_ds + 1, -1:n_ds + 1, -1:p_ds + 1) + MPI_IO_DATA%var(i)%sf => q_cons_vf(i)%sf(-1:m_ds + 1,-1:n_ds + 1,-1:p_ds + 1) end do #endif ! Define global(g) and local(l) sizes for flow variables @@ -229,12 +225,12 @@ contains !> Gather variable-length real vectors from all MPI ranks onto the root process. impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root) - integer, intent(in) :: counts ! Array of vector lengths for each process - real(wp), intent(in), dimension(counts) :: my_vector ! Input vector on each process - integer, intent(in) :: root ! Rank of the root process - real(wp), allocatable, intent(out) :: gathered_vector(:) ! Gathered vector on the root process + integer, intent(in) :: counts !< Array of vector lengths for each process + real(wp), intent(in), dimension(counts) :: my_vector !< Input vector on each process + integer, intent(in) :: root !< Rank of the root process + real(wp), allocatable, intent(out) :: gathered_vector(:) !< Gathered vector on the root process integer :: i - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: ierr !< Generic flag used to identify and report MPI errors integer, allocatable :: recounts(:), displs(:) #ifdef MFC_MPI @@ -353,7 +349,7 @@ contains call MPI_Allreduce(var_loc, var_glb, num_vectors*vector_length, mpi_p, MPI_SUM, MPI_COMM_WORLD, ierr) end if #else - var_glb(1:num_vectors, 1:vector_length) = var_loc(1:num_vectors, 1:vector_length) + var_glb(1:num_vectors,1:vector_length) = var_loc(1:num_vectors,1:vector_length) #endif end subroutine s_mpi_allreduce_vectors_sum @@ -427,10 +423,8 @@ contains real(wp), dimension(2), intent(inout) :: var_loc #ifdef MFC_MPI - integer :: ierr !< Generic flag used to identify and report MPI errors - !> Temporary storage variable that holds the reduced maximum value and the rank of the processor with which the value is - !! associated - real(wp), dimension(2) :: var_glb + integer :: ierr !< Generic flag used to identify and report MPI errors + real(wp), dimension(2) :: var_glb !< Reduced (max value, rank) pair call MPI_REDUCE(var_loc, var_glb, 1, mpi_2p, MPI_MAXLOC, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST(var_glb, 1, mpi_2p, 0, MPI_COMM_WORLD, ierr) @@ -498,7 +492,7 @@ contains subroutine s_mpi_sendrecv_variables_buffers(q_comm, mpi_dir, pbc_loc, nVar, pb_in, mv_in) type(scalar_field), dimension(1:), intent(inout) :: q_comm - real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in, mv_in + real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in integer, intent(in) :: mpi_dir, pbc_loc, nVar integer :: i, j, k, l, r, q !< Generic loop iterators integer :: buffer_counts(1:3), buffer_count @@ -918,12 +912,10 @@ contains real(wp) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z real(wp) :: fct_min !< Processor factorization (fct) minimization parameter integer :: MPI_COMM_CART !< Cartesian processor topology communicator - !> Remaining number of cells, in a particular coordinate direction, after the majority is divided up among the available - !! processors - integer :: rem_cells - integer :: recon_order !< WENO or MUSCL reconstruction order - integer :: i, j !< Generic loop iterators - integer :: ierr !< Generic flag used to identify and report MPI errors + integer :: rem_cells !< Remaining cells after distribution among processors + integer :: recon_order !< WENO or MUSCL reconstruction order + integer :: i, j !< Generic loop iterators + integer :: ierr !< Generic flag used to identify and report MPI errors if (recon_type == WENO_TYPE) then recon_order = weno_order diff --git a/src/common/m_nvtx.f90 b/src/common/m_nvtx.f90 index 4708c8b78e..66893c10d0 100644 --- a/src/common/m_nvtx.f90 +++ b/src/common/m_nvtx.f90 @@ -18,13 +18,13 @@ module m_nvtx integer(c_int16_t) :: version = 1 integer(c_int16_t) :: size = 48 ! integer(c_int) :: category = 0 - integer(c_int) :: colorType = 1 ! NVTX_COLOR_ARGB = 1 + integer(c_int) :: colorType = 1 !< NVTX_COLOR_ARGB = 1 integer(c_int) :: color - integer(c_int) :: payloadType = 0 ! NVTX_PAYLOAD_UNKNOWN = 0 + integer(c_int) :: payloadType = 0 !< NVTX_PAYLOAD_UNKNOWN = 0 integer(c_int) :: reserved0 - integer(c_int64_t) :: payload ! union uint,int,double - integer(c_int) :: messageType = 1 ! NVTX_MESSAGE_TYPE_ASCII = 1 - type(c_ptr) :: message ! ascii char + integer(c_int64_t) :: payload !< union uint,int,double + integer(c_int) :: messageType = 1 !< NVTX_MESSAGE_TYPE_ASCII = 1 + type(c_ptr) :: message !< ascii char end type nvtxEventAttributes #if defined(MFC_GPU) && defined(__PGI) diff --git a/src/common/m_phase_change.fpp b/src/common/m_phase_change.fpp index 6114aa2d0e..21926411db 100644 --- a/src/common/m_phase_change.fpp +++ b/src/common/m_phase_change.fpp @@ -15,6 +15,7 @@ module m_phase_change use m_variables_conversion use ieee_arithmetic use m_helper_basic + implicit none private @@ -22,12 +23,12 @@ module m_phase_change !> @name Parameters for the first order transition phase change !> @{ - integer, parameter :: max_iter = 1e8_wp !< max # of iterations - real(wp), parameter :: pCr = 4.94e7_wp ! Critical pressure of water [Pa] - real(wp), parameter :: TCr = 385.05_wp + 273.15_wp ! Critical temperature of water [K] - real(wp), parameter :: mixM = 1.0e-8_wp ! Mixture mass fraction threshold for triggering phase change - integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid - integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid + integer, parameter :: max_iter = 1e8_wp !< max # of iterations + real(wp), parameter :: pCr = 4.94e7_wp !< Critical pressure of water [Pa] + real(wp), parameter :: TCr = 385.05_wp + 273.15_wp !< Critical temperature of water [K] + real(wp), parameter :: mixM = 1.0e-8_wp !< Mixture mass fraction threshold for triggering phase change + integer, parameter :: lp = 1 !< index for the liquid phase of the reacting fluid + integer, parameter :: vp = 2 !< index for the vapor phase of the reacting fluid !> @} !> @name Gibbs free energy phase change parameters @@ -67,13 +68,11 @@ contains subroutine s_infinite_relaxation_k(q_cons_vf) type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid - !> equilibrium temperature for mixture, overheated vapor, and subcooled liquid. Saturation Temperatures at overheated vapor - !! and subcooled liquid - real(wp) :: TS, TSOV, TSSL, TSatOV, TSatSL - real(wp) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy - real(wp) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses - real(wp) :: TvF !< total volume fraction + real(wp) :: pS, pSOV, pSSL !< equilibrium pressure for mixture, overheated vapor, and subcooled liquid + real(wp) :: TS, TSOV, TSSL, TSatOV, TSatSL !< Equilibrium and saturation temperatures + real(wp) :: rhoe, dynE, rhos !< total internal energy, kinetic energy, and total entropy + real(wp) :: rho, rM, m1, m2, MCT !< total density, total reacting mass, individual reacting masses + real(wp) :: TvF !< total volume fraction ! $:GPU_DECLARE(create='[pS,pSOV,pSSL,TS,TSOV,TSSL,TSatOV,TSatSL]') ! $:GPU_DECLARE(create='[rhoe,dynE,rhos,rho,rM,m1,m2,MCT,TvF]') @@ -361,10 +360,10 @@ contains #:else real(wp), dimension(num_fluids) :: p_infpTg !< stiffness for the participating fluids for pTg-equilibrium #:endif - real(wp), dimension(2, 2) :: Jac, InvJac, TJac !< matrices for the Newton Solver - real(wp), dimension(2) :: R2D, DeltamP !< residual and correction array - real(wp) :: Om ! underrelaxation factor - real(wp) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD ! auxiliary variables for the pTg-solver + real(wp), dimension(2, 2) :: Jac, InvJac, TJac !< matrices for the Newton Solver + real(wp), dimension(2) :: R2D, DeltamP !< residual and correction array + real(wp) :: Om !< underrelaxation factor + real(wp) :: mCP, mCPD, mCVGP, mCVGP2, mQ, mQD !< auxiliary variables for the pTg-solver real(wp) :: ml, mT, dFdT, dTdm, dTdp !> Generic loop iterators diff --git a/src/common/m_precision_select.f90 b/src/common/m_precision_select.f90 index 5fc1c5c667..7c730cf303 100644 --- a/src/common/m_precision_select.f90 +++ b/src/common/m_precision_select.f90 @@ -13,7 +13,7 @@ module m_precision_select implicit none ! Define the available precision types - integer, parameter :: half_precision = 2 ! selected_real_kind(3, 4) + integer, parameter :: half_precision = 2 !< selected_real_kind(3, 4) integer, parameter :: single_precision = selected_real_kind(6, 37) integer, parameter :: double_precision = selected_real_kind(15, 307) integer, parameter :: hp = half_precision @@ -22,7 +22,7 @@ module m_precision_select ! Set the working precision (wp) to single or double #ifdef MFC_SINGLE_PRECISION - integer, parameter :: wp = single_precision ! Change to single_precision if needed + integer, parameter :: wp = single_precision !< Change to single_precision if needed #else integer, parameter :: wp = double_precision #endif @@ -42,7 +42,7 @@ module m_precision_select ! MPI types per element. IE Real(kind=2) <=> 2 MPI_BYTE integer, parameter :: mpi_io_type = merge(2, 1, stp == half_precision) #else - integer, parameter :: mpi_p = -100 ! Default value when MPI is not used + integer, parameter :: mpi_p = -100 !< Default value when MPI is not used integer, parameter :: mpi_2p = -100 integer, parameter :: mpi_io_p = -100 integer, parameter :: mpi_io_type = -100 diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index cdd9c26ad7..9fdae1258b 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -368,25 +368,25 @@ contains if (n > 0) then ! Simulation is 3D if (p > 0) then - allocate (rho_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, -buff_size:p + buff_size)) - allocate (gamma_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, -buff_size:p + buff_size)) - allocate (pi_inf_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, -buff_size:p + buff_size)) - allocate (qv_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, -buff_size:p + buff_size)) + allocate (rho_sf(-buff_size:m + buff_size,-buff_size:n + buff_size,-buff_size:p + buff_size)) + allocate (gamma_sf(-buff_size:m + buff_size,-buff_size:n + buff_size,-buff_size:p + buff_size)) + allocate (pi_inf_sf(-buff_size:m + buff_size,-buff_size:n + buff_size,-buff_size:p + buff_size)) + allocate (qv_sf(-buff_size:m + buff_size,-buff_size:n + buff_size,-buff_size:p + buff_size)) ! Simulation is 2D else - allocate (rho_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) - allocate (gamma_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) - allocate (pi_inf_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) - allocate (qv_sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) + allocate (rho_sf(-buff_size:m + buff_size,-buff_size:n + buff_size,0:0)) + allocate (gamma_sf(-buff_size:m + buff_size,-buff_size:n + buff_size,0:0)) + allocate (pi_inf_sf(-buff_size:m + buff_size,-buff_size:n + buff_size,0:0)) + allocate (qv_sf(-buff_size:m + buff_size,-buff_size:n + buff_size,0:0)) end if ! Simulation is 1D else - allocate (rho_sf(-buff_size:m + buff_size, 0:0, 0:0)) - allocate (gamma_sf(-buff_size:m + buff_size, 0:0, 0:0)) - allocate (pi_inf_sf(-buff_size:m + buff_size, 0:0, 0:0)) - allocate (qv_sf(-buff_size:m + buff_size, 0:0, 0:0)) + allocate (rho_sf(-buff_size:m + buff_size,0:0,0:0)) + allocate (gamma_sf(-buff_size:m + buff_size,0:0,0:0)) + allocate (pi_inf_sf(-buff_size:m + buff_size,0:0,0:0)) + allocate (qv_sf(-buff_size:m + buff_size,0:0,0:0)) end if #endif @@ -395,10 +395,10 @@ contains !> Initialize bubble mass-vapor values at quadrature nodes from the conserved moment statistics. subroutine s_initialize_mv(qK_cons_vf, mv) - type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: mv - integer :: i, j, k, l - real(wp) :: mu, sig, nbub_sc + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf + real(stp), dimension(idwint(1)%beg:,idwint(2)%beg:,idwint(3)%beg:,1:,1:), intent(inout) :: mv + integer :: i, j, k, l + real(wp) :: mu, sig, nbub_sc do l = idwint(3)%beg, idwint(3)%end do k = idwint(2)%beg, idwint(2)%end @@ -424,11 +424,11 @@ contains !> Initialize bubble internal pressures at quadrature nodes using isothermal relations from the Preston model. subroutine s_initialize_pb(qK_cons_vf, mv, pb) - type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(in) :: mv - real(stp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: pb - integer :: i, j, k, l - real(wp) :: mu, sig, nbub_sc + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf + real(stp), dimension(idwint(1)%beg:,idwint(2)%beg:,idwint(3)%beg:,1:,1:), intent(in) :: mv + real(stp), dimension(idwint(1)%beg:,idwint(2)%beg:,idwint(3)%beg:,1:,1:), intent(inout) :: pb + integer :: i, j, k, l + real(wp) :: mu, sig, nbub_sc do l = idwint(3)%beg, idwint(3)%end do k = idwint(2)%beg, idwint(2)%end @@ -479,18 +479,18 @@ contains real(wp) :: vftmp, nbub_sc real(wp) :: G_K real(wp) :: pres - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators real(wp) :: T real(wp) :: pres_mag - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: B2 ! Magnetic field magnitude squared - real(wp) :: B(3) ! Magnetic field components - real(wp) :: m2 ! Relativistic momentum magnitude squared - real(wp) :: S ! Dot product of the magnetic field and the relativistic momentum - real(wp) :: W, dW ! W := rho*v*Ga**2; f = f(W) in Newton-Raphson - real(wp) :: E, D ! Prim/Cons variables within Newton-Raphson iteration - real(wp) :: f, dGa_dW, dp_dW, df_dW ! Functions within Newton-Raphson iteration - integer :: iter ! Newton-Raphson iteration counter + real(wp) :: Ga !< Lorentz factor (gamma in relativity) + real(wp) :: B2 !< Magnetic field magnitude squared + real(wp) :: B(3) !< Magnetic field components + real(wp) :: m2 !< Relativistic momentum magnitude squared + real(wp) :: S !< Dot product of the magnetic field and the relativistic momentum + real(wp) :: W, dW !< W := rho*v*Ga**2; f = f(W) in Newton-Raphson + real(wp) :: E, D !< Prim/Cons variables within Newton-Raphson iteration + real(wp) :: f, dGa_dW, dp_dW, df_dW !< Functions within Newton-Raphson iteration + integer :: iter !< Newton-Raphson iteration counter $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_K, alpha_rho_K, Re_K, nRtmp, rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K, & & rhoYks, B, pres, vftmp, nbub_sc, G_K, T, pres_mag, Ga, B2, m2, S, W, dW, E, D, f, dGa_dW, dp_dW, & @@ -790,12 +790,12 @@ contains real(wp), dimension(num_species) :: Ys real(wp) :: e_mix, mix_mol_weight, T real(wp) :: pres_mag - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: h ! relativistic enthalpy - real(wp) :: v2 ! Square of the velocity magnitude - real(wp) :: B2 ! Square of the magnetic field magnitude - real(wp) :: vdotB ! Dot product of the velocity and magnetic field vectors - real(wp) :: B(3) ! Magnetic field components + real(wp) :: Ga !< Lorentz factor (gamma in relativity) + real(wp) :: h !< relativistic enthalpy + real(wp) :: v2 !< Square of the velocity magnitude + real(wp) :: B2 !< Square of the magnetic field magnitude + real(wp) :: vdotB !< Dot product of the velocity and magnetic field vectors + real(wp) :: B(3) !< Magnetic field components pres_mag = 0._wp @@ -1016,11 +1016,11 @@ contains !> Convert primitive variables to Eulerian flux variables. subroutine s_convert_primitive_to_flux_variables(qK_prim_vf, FK_vf, FK_src_vf, is1, is2, is3, s2b, s3b) - integer, intent(in) :: s2b, s3b - real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: qK_prim_vf - real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: FK_vf - real(wp), dimension(0:, idwbuff(2)%beg:, idwbuff(3)%beg:, advxb:), intent(inout) :: FK_src_vf - type(int_bounds_info), intent(in) :: is1, is2, is3 + integer, intent(in) :: s2b, s3b + real(wp), dimension(0:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(in) :: qK_prim_vf + real(wp), dimension(0:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: FK_vf + real(wp), dimension(0:,idwbuff(2)%beg:,idwbuff(3)%beg:,advxb:), intent(inout) :: FK_src_vf + type(int_bounds_info), intent(in) :: is1, is2, is3 ! Partial densities, density, velocity, pressure, energy, advection variables, the specific heat ratio and liquid stiffness ! functions, the shear and volume Reynolds numbers and the Weber numbers @@ -1299,7 +1299,7 @@ contains $:GPU_ROUTINE(function_name='s_compute_fast_magnetosonic_speed', parallelism='[seq]', cray_noinline=True) real(wp), intent(in) :: B(3), rho, c - real(wp), intent(in) :: h ! only used for relativity + real(wp), intent(in) :: h !< only used for relativity real(wp), intent(out) :: c_fast integer, intent(in) :: norm real(wp) :: B2, term, disc diff --git a/src/post_process/m_data_input.f90 b/src/post_process/m_data_input.f90 index 612e84e4be..3a75c391f2 100644 --- a/src/post_process/m_data_input.f90 +++ b/src/post_process/m_data_input.f90 @@ -152,7 +152,7 @@ impure subroutine s_read_ib_data_files(file_loc_base, t_step) #endif else open (2, FILE=trim(file_loc), form='unformatted', ACTION='read', STATUS='old') - read (2) ib_markers%sf(0:m, 0:n, 0:p) + read (2) ib_markers%sf(0:m,0:n,0:p) close (2) end if else @@ -168,16 +168,16 @@ impure subroutine s_allocate_field_arrays(local_start_idx, end_x, end_y, end_z) integer :: i do i = 1, sys_size - allocate (q_cons_vf(i)%sf(local_start_idx:end_x, local_start_idx:end_y, local_start_idx:end_z)) - allocate (q_prim_vf(i)%sf(local_start_idx:end_x, local_start_idx:end_y, local_start_idx:end_z)) + allocate (q_cons_vf(i)%sf(local_start_idx:end_x,local_start_idx:end_y,local_start_idx:end_z)) + allocate (q_prim_vf(i)%sf(local_start_idx:end_x,local_start_idx:end_y,local_start_idx:end_z)) end do if (ib) then - allocate (ib_markers%sf(local_start_idx:end_x, local_start_idx:end_y, local_start_idx:end_z)) + allocate (ib_markers%sf(local_start_idx:end_x,local_start_idx:end_y,local_start_idx:end_z)) end if if (chemistry) then - allocate (q_T_sf%sf(local_start_idx:end_x, local_start_idx:end_y, local_start_idx:end_z)) + allocate (q_T_sf%sf(local_start_idx:end_x,local_start_idx:end_y,local_start_idx:end_z)) end if end subroutine s_allocate_field_arrays @@ -228,11 +228,11 @@ impure subroutine s_read_serial_data_files(t_step) if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') - read (1) q_cons_vf(i)%sf(0:m, 0:n, 0:p) + read (1) q_cons_vf(i)%sf(0:m,0:n,0:p) close (1) else if (bubbles_lagrange .and. i == beta_idx) then ! beta (Lagrangian void fraction) is not written by pre_process for t_step_start; initialize to zero. - q_cons_vf(i)%sf(0:m, 0:n, 0:p) = 0._wp + q_cons_vf(i)%sf(0:m,0:n,0:p) = 0._wp else call s_mpi_abort('File q_cons_vf' // trim(file_num) // '.dat is missing in ' // trim(t_step_dir) // '. Exiting.') end if @@ -425,7 +425,7 @@ impure subroutine s_read_parallel_conservative_data(t_step, m_MOK, n_MOK, p_MOK, if (down_sample) then do i = 1, sys_size - q_cons_vf(i)%sf(0:m, 0:n, 0:p) = q_cons_temp(i)%sf(0:m, 0:n, 0:p) + q_cons_vf(i)%sf(0:m,0:n,0:p) = q_cons_temp(i)%sf(0:m,0:n,0:p) end do end if @@ -478,7 +478,7 @@ impure subroutine s_initialize_data_input_module call s_allocate_field_arrays(-buff_size, m + buff_size, n + buff_size, p + buff_size) if (down_sample) then do i = 1, sys_size - allocate (q_cons_temp(i)%sf(-1:m + 1, -1:n + 1, -1:p + 1)) + allocate (q_cons_temp(i)%sf(-1:m + 1,-1:n + 1,-1:p + 1)) end do end if else @@ -488,16 +488,16 @@ impure subroutine s_initialize_data_input_module call s_allocate_field_arrays(-buff_size, m + buff_size, 0, 0) end if - allocate (bc_type(1:num_dims, 1:2)) + allocate (bc_type(1:num_dims,1:2)) - allocate (bc_type(1, 1)%sf(0:0, 0:n, 0:p)) - allocate (bc_type(1, 2)%sf(0:0, 0:n, 0:p)) + allocate (bc_type(1, 1)%sf(0:0,0:n,0:p)) + allocate (bc_type(1, 2)%sf(0:0,0:n,0:p)) if (n > 0) then - allocate (bc_type(2, 1)%sf(-buff_size:m + buff_size, 0:0, 0:p)) - allocate (bc_type(2, 2)%sf(-buff_size:m + buff_size, 0:0, 0:p)) + allocate (bc_type(2, 1)%sf(-buff_size:m + buff_size,0:0,0:p)) + allocate (bc_type(2, 2)%sf(-buff_size:m + buff_size,0:0,0:p)) if (p > 0) then - allocate (bc_type(3, 1)%sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) - allocate (bc_type(3, 2)%sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) + allocate (bc_type(3, 1)%sf(-buff_size:m + buff_size,-buff_size:n + buff_size,0:0)) + allocate (bc_type(3, 2)%sf(-buff_size:m + buff_size,-buff_size:n + buff_size,0:0)) end if end if diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 51fa34a4a1..0ac093288f 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -81,23 +81,22 @@ 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 (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 (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 == 1) 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 (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 (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 (q_root_sf(0:m_root,0:0,0:0)) if (precision == 1) then - allocate (q_root_sf_s(0:m_root, 0:0, 0:0)) + allocate (q_root_sf_s(0:m_root,0:0,0:0)) end if end if @@ -105,20 +104,20 @@ 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 == 1) then - allocate (data_extents(1:2, 0:num_procs - 1)) + allocate (data_extents(1:2,0:num_procs - 1)) if (p > 0) then - allocate (spatial_extents(1:6, 0:num_procs - 1)) + allocate (spatial_extents(1:6,0:num_procs - 1)) allocate (lo_offset(1:3)) allocate (hi_offset(1:3)) allocate (dims(1:3)) else if (n > 0) then - allocate (spatial_extents(1:4, 0:num_procs - 1)) + allocate (spatial_extents(1:4,0:num_procs - 1)) allocate (lo_offset(1:2)) allocate (hi_offset(1:2)) allocate (dims(1:2)) else - allocate (spatial_extents(1:2, 0:num_procs - 1)) + allocate (spatial_extents(1:2,0:num_procs - 1)) allocate (lo_offset(1:1)) allocate (hi_offset(1:1)) allocate (dims(1:1)) @@ -456,14 +455,14 @@ contains call s_mpi_gather_spatial_extents(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)/) + 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)/) + 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)/) + 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)/) + 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 @@ -592,7 +591,7 @@ contains if (num_procs > 1) then call s_mpi_gather_data_extents(q_sf, data_extents) else - data_extents(:, 0) = (/minval(q_sf), maxval(q_sf)/) + data_extents(:,0) = (/minval(q_sf), maxval(q_sf)/) end if if (proc_rank == 0) then @@ -716,20 +715,20 @@ contains integer :: id #ifdef MFC_MPI - real(wp), dimension(20) :: inputvals - real(wp) :: time_real - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer :: view - logical :: lg_bub_file, file_exist - integer, dimension(2) :: gsizes, lsizes, start_idx_part - integer :: ifile - integer :: ierr - real(wp) :: file_time, file_dt - integer :: file_num_procs, file_tot_part, tot_part - integer :: i - integer, dimension(:), allocatable :: proc_bubble_counts - real(wp), dimension(1:1, 1:lag_io_vars) :: lag_io_null + real(wp), dimension(20) :: inputvals + real(wp) :: time_real + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer :: view + logical :: lg_bub_file, file_exist + integer, dimension(2) :: gsizes, lsizes, start_idx_part + integer :: ifile + integer :: ierr + real(wp) :: file_time, file_dt + integer :: file_num_procs, file_tot_part, tot_part + integer :: i + integer, dimension(:), allocatable :: proc_bubble_counts + real(wp), dimension(1:1,1:lag_io_vars) :: lag_io_null lag_io_null = 0._wp @@ -793,7 +792,7 @@ contains & + file_num_procs*sizeof(proc_bubble_counts(1)), MPI_OFFSET_KIND) call MPI_FILE_SET_VIEW(ifile, disp, mpi_p, view, 'native', mpi_info_null, ierr) - allocate (MPI_IO_DATA_lg_bubbles(file_tot_part, 1:lag_io_vars)) + allocate (MPI_IO_DATA_lg_bubbles(file_tot_part,1:lag_io_vars)) call MPI_FILE_READ_ALL(ifile, MPI_IO_DATA_lg_bubbles, lag_io_vars*file_tot_part, mpi_p, status, ierr) @@ -825,7 +824,7 @@ contains do i = 1, file_tot_part id = int(MPI_IO_DATA_lg_bubbles(i, 1)) - inputvals(1:20) = MPI_IO_DATA_lg_bubbles(i, 2:21) + inputvals(1:20) = MPI_IO_DATA_lg_bubbles(i,2:21) if (id > 0) then write (29, '(100(A))', advance='no') '' if (lag_id_wrt) write (29, '(I6, A)', advance='no') id, ', ' @@ -880,7 +879,7 @@ contains real(wp) :: file_time, file_dt integer :: file_num_procs, file_tot_part integer, dimension(:), allocatable :: proc_bubble_counts - real(wp), dimension(1:1, 1:lag_io_vars) :: dummy + real(wp), dimension(1:1,1:lag_io_vars) :: dummy character(LEN=4*name_len), dimension(num_procs) :: meshnames integer, dimension(num_procs) :: meshtypes real(wp) :: dummy_data @@ -959,7 +958,7 @@ contains 'pressure', 'mv', 'mg', 'betaT', 'betaC'] allocate (${VAR}$ (nBub)) #:endfor - allocate (MPI_IO_DATA_lg_bubbles(nBub, 1:lag_io_vars)) + allocate (MPI_IO_DATA_lg_bubbles(nBub,1:lag_io_vars)) call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, MPI_ORDER_FORTRAN, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) @@ -981,7 +980,7 @@ contains ('vx',8), ('vy',9), ('vz',10), ('radius',11), ('rvel',12), & ('rnot',13), ('rmax',14), ('rmin',15), ('dphidt',16), & ('pressure',17), ('mv',18), ('mg',19), ('betaT',20), ('betaC',21)] - ${VAR}$ (:) = MPI_IO_DATA_lg_bubbles(:, ${IDX}$) + ${VAR}$ (:) = MPI_IO_DATA_lg_bubbles(:,${IDX}$) #:endfor ! Next, the root processor proceeds to record all of the spatial extents in the formatted database master file. In @@ -1259,7 +1258,7 @@ contains real(wp) :: rho, pres, dV, tmp, gamma, pi_inf, MaxMa, MaxMa_glb, maxvel, c, Ma, H, qv real(wp), dimension(num_vels) :: vel real(wp), dimension(num_fluids) :: adv - integer :: i, j, k, l, s ! looping indices + integer :: i, j, k, l, s !< looping indices Egk = 0._wp Elp = 0._wp diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index ddf7c61f9e..daa9ca6dbf 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -18,9 +18,7 @@ module m_derived_variables & 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 - !> Gradient magnitude (gm) of the density for each cell of the computational sub-domain. This variable is employed in the - !! calculation of the numerical Schlieren function. - real(wp), allocatable, dimension(:,:,:) :: gm_rho_sf + 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. @@ -30,12 +28,7 @@ module m_derived_variables real(wp), allocatable, dimension(:,:), public :: fd_coeff_z !> @} - !> Flagging (flg) variable used to annotate the dimensionality of the dataset that is undergoing the post-process. A flag value - !! of 1 indicates that the dataset is 3D, while a flag value of 0 indicates that it is not. This flg variable is necessary to - !! avoid cycling through the third dimension of the flow variable(s) when the simulation is not 3D and the size of the buffer is - !! non-zero. Note that a similar procedure does not have to be applied to the second dimension since in 1D, the buffer size is - !! always zero. - integer, private :: flg + integer, private :: flg !< Dimensionality flag: 1 = 3D dataset, 0 = otherwise contains @@ -44,21 +37,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 (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_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_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_coeff_z(-fd_number:fd_number,-offset_z%beg:p + offset_z%end)) end if if (p > 0) then @@ -73,7 +66,7 @@ contains !! quantity storage variable, q_sf. subroutine s_derive_specific_heat_ratio(q_sf) - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf integer :: i, j, k @@ -92,7 +85,7 @@ contains !! storage variable, q_sf. subroutine s_derive_liquid_stiffness(q_sf) - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf integer :: i, j, k @@ -113,7 +106,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf integer :: i, j, k @@ -150,7 +143,7 @@ contains integer, intent(in) :: i type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf real(wp) :: top, bottom, slope @@ -226,7 +219,7 @@ contains ! Forward elimination with partial pivoting do i = 1, ndim - j = i - 1 + maxloc(abs(A(i:ndim, i)), 1) + j = i - 1 + maxloc(abs(A(i:ndim,i)), 1) sol = A(i,:) A(i,:) = A(j,:) A(j,:) = sol @@ -257,7 +250,7 @@ contains integer, intent(in) :: i type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf integer :: j, k, l, r @@ -321,12 +314,12 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - real(wp), dimension(1:3, 1:3) :: q_jacobian_sf, S, S2, O, O2 - real(wp) :: trS, Q, IIS - integer :: j, k, l, r, jj, kk + real(wp), dimension(1:3,1:3) :: q_jacobian_sf, S, S2, O, O2 + real(wp) :: trS, Q, IIS + integer :: j, k, l, r, jj, kk do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end do j = -offset_x%beg, m + offset_x%end @@ -384,10 +377,10 @@ contains !> Liutex magnitude - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end), & & intent(out) :: liutex_mag !> Liutex rigid rotation axis - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, nm), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end,nm), & & intent(out) :: liutex_axis character, parameter :: ivl = 'N' !< compute left eigenvectors character, parameter :: ivr = 'V' !< compute right eigenvectors @@ -436,7 +429,7 @@ contains idx = r end if end do - eigvec = vr(:, idx) + eigvec = vr(:,idx) ! Normalize real eigenvector if it is effectively non-zero eigvec_mag = sqrt(eigvec(1)**2._wp + eigvec(2)**2._wp + eigvec(3)**2._wp) @@ -484,14 +477,11 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end), & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end), & & intent(inout) :: q_sf - real(wp) :: drho_dx, drho_dy, drho_dz !< Spatial derivatives of the density in the x-, y- and z-directions - !> Maximum value of the gradient magnitude (gm) of the density field in entire computational domain and not just the local - !! sub-domain. The first position in the variable contains the maximum value and the second contains the rank of the - !! processor on which it occurred. - real(wp), dimension(2) :: gm_rho_max + real(wp) :: drho_dx, drho_dy, drho_dz !< Spatial derivatives of the density in the x-, y- and z-directions + real(wp), dimension(2) :: gm_rho_max !< Global (max gradient magnitude, rank) pair for density integer :: i, j, k, l do l = -offset_z%beg, p + offset_z%end diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index 0fd3dc4fd7..0530c31081 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -35,7 +35,7 @@ module m_global_parameters !> @name Max and min number of cells in a direction of each combination of x-,y-, and z- type(cell_num_bounds) :: cells_bounds - integer(kind=8) :: nGlobal ! Total number of cells in global domain + integer(kind=8) :: nGlobal !< Total number of cells in global domain !> @name Cylindrical coordinates (either axisymmetric or full 3D) !> @{ @@ -66,9 +66,7 @@ module m_global_parameters real(wp), allocatable, dimension(:) :: dx, dy, dz !> @} - !> Number of cells in buffer region. For the variables which feature a buffer region, this region is used to store information - !! outside the computational domain based on the boundary conditions. - integer :: buff_size + integer :: buff_size !< Number of ghost cells for boundary condition storage integer :: t_step_start !< First time-step directory integer :: t_step_stop !< Last time-step directory integer :: t_step_save !< Interval between consecutive time-step directory @@ -146,18 +144,16 @@ module m_global_parameters type(int_bounds_info) :: bc_x, bc_y, bc_z !> @} - integer :: shear_num !< Number of shear stress components - integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions - !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, - !! [indices]) - integer, dimension(3, 2) :: shear_BC_flip_indices - logical :: parallel_io !< Format of the data files + integer :: shear_num !< Number of shear stress components + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + integer, dimension(3, 2) :: shear_BC_flip_indices !< Shear stress BC reflection indices (1:3, 1:shear_BC_flip_num) + logical :: parallel_io !< Format of the data files logical :: sim_data logical :: file_per_process !< output format - integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM - integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid - integer :: num_ibs !< Number of immersed boundaries + integer, allocatable, dimension(:) :: proc_coords !< Processor coordinates in MPI_CART_COMM + integer, allocatable, dimension(:) :: start_idx !< Starting cell-center index of local processor in global grid + integer :: num_ibs !< Number of immersed boundaries #ifdef MFC_MPI type(mpi_io_var), public :: MPI_IO_DATA type(mpi_io_ib_var), public :: MPI_IO_IB_DATA @@ -172,9 +168,7 @@ module m_global_parameters integer :: mpi_info_int !> @} - !> Database of the physical parameters of each of the fluids that is present in the flow. These include the stiffened gas - !! equation of state parameters, and the Reynolds numbers. - type(physical_parameters), dimension(num_fluids_max) :: fluid_pp + type(physical_parameters), dimension(num_fluids_max) :: fluid_pp !< Stiffened gas EOS parameters and Reynolds numbers per fluid ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp real(wp), allocatable, dimension(:) :: adv !< Advection variables @@ -207,9 +201,7 @@ module m_global_parameters logical :: E_wrt logical, dimension(num_fluids_max) :: alpha_rho_e_wrt logical :: fft_wrt - !> AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional - !! is false - logical :: dummy + logical :: dummy !< AMDFlang workaround for case-optimization + GPU-kernel bug logical :: pres_wrt logical, dimension(num_fluids_max) :: alpha_wrt logical :: gamma_wrt @@ -248,16 +240,9 @@ module m_global_parameters logical :: lag_betaC_wrt !> @} - !> Amplitude coefficients of the numerical Schlieren function that are used to adjust the intensity of numerical Schlieren - !! renderings for individual fluids. This enables waves and interfaces of varying strengths and in all of the fluids to be made - !! simultaneously visible on a single plot. - real(wp), dimension(num_fluids_max) :: schlieren_alpha - !> The order of the finite-difference (fd) approximations of the first-order derivatives that need to be evaluated when - !! vorticity and/or the numerical Schlieren function are to be outputted to the formatted database file(s). - integer :: fd_order - !> The finite-difference number is given by MAX(1, fd_order/2). Essentially, it is a measure of the half-size of the - !! finite-difference stencil for the selected order of accuracy. - integer :: fd_number + real(wp), dimension(num_fluids_max) :: schlieren_alpha !< Per-fluid Schlieren intensity amplitude coefficients + integer :: fd_order !< Finite-difference order for vorticity and Schlieren derivatives + integer :: fd_number !< Finite-difference half-stencil size: MAX(1, fd_order/2) !> @name Reference parameters for Tait EOS !> @{ real(wp) :: rhoref, pref @@ -720,15 +705,15 @@ contains shear_num = 1 shear_indices(1) = stress_idx%beg - 1 + 2 shear_BC_flip_num = 1 - shear_BC_flip_indices(1:2, 1) = shear_indices(1) + shear_BC_flip_indices(1:2,1) = shear_indices(1) ! Both x-dir and y-dir: flip tau_xy only else if (num_dims == 3) then shear_num = 3 shear_indices(1:3) = stress_idx%beg - 1 + (/2, 4, 5/) shear_BC_flip_num = 2 - shear_BC_flip_indices(1, 1:2) = shear_indices((/1, 2/)) - shear_BC_flip_indices(2, 1:2) = shear_indices((/1, 3/)) - shear_BC_flip_indices(3, 1:2) = shear_indices((/2, 3/)) + shear_BC_flip_indices(1,1:2) = shear_indices((/1, 2/)) + shear_BC_flip_indices(2,1:2) = shear_indices((/1, 3/)) + shear_BC_flip_indices(3,1:2) = shear_indices((/2, 3/)) ! x-dir: flip tau_xy and tau_xz y-dir: flip tau_xy and tau_yz z-dir: flip tau_xz and tau_yz end if end if @@ -809,20 +794,20 @@ contains do i = 1, sys_size if (down_sample) then - allocate (MPI_IO_DATA%var(i)%sf(-1:m + 1, -1:n + 1, -1:p + 1)) + allocate (MPI_IO_DATA%var(i)%sf(-1:m + 1,-1:n + 1,-1:p + 1)) else - allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) + allocate (MPI_IO_DATA%var(i)%sf(0:m,0:n,0:p)) end if MPI_IO_DATA%var(i)%sf => null() end do if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode - allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) + allocate (MPI_IO_DATA%var(i)%sf(0:m,0:n,0:p)) MPI_IO_DATA%var(i)%sf => null() end do end if - if (ib) allocate (MPI_IO_IB_DATA%var%sf(0:m, 0:n, 0:p)) + if (ib) allocate (MPI_IO_IB_DATA%var%sf(0:m,0:n,0:p)) #endif ! Size of the ghost zone layer is non-zero only when post-processing the raw simulation data of a parallel multidimensional diff --git a/src/post_process/m_mpi_proxy.fpp b/src/post_process/m_mpi_proxy.fpp index 19f899ff71..c91f140d39 100644 --- a/src/post_process/m_mpi_proxy.fpp +++ b/src/post_process/m_mpi_proxy.fpp @@ -141,7 +141,7 @@ contains !> Gather spatial extents from all ranks for Silo database metadata impure subroutine s_mpi_gather_spatial_extents(spatial_extents) - real(wp), dimension(1:, 0:), intent(inout) :: spatial_extents + real(wp), dimension(1:,0:), intent(inout) :: spatial_extents #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors @@ -254,8 +254,8 @@ contains !! @param q_sf Flow variable on a single computational sub-domain impure subroutine s_mpi_gather_data_extents(q_sf, data_extents) - real(wp), dimension(:,:,:), intent(in) :: q_sf - real(wp), dimension(1:2, 0:num_procs - 1), intent(inout) :: data_extents + real(wp), dimension(:,:,:), intent(in) :: q_sf + real(wp), dimension(1:2,0:num_procs - 1), intent(inout) :: data_extents #ifdef MFC_MPI integer :: ierr !< Generic flag used to identify and report MPI errors diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index e964265775..c65e4cf7cf 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -173,9 +173,9 @@ contains real(wp), intent(inout) :: pres, c, H real(wp) :: theta1, theta2 - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end, & & -offset_z%beg:p + offset_z%end) :: liutex_mag - real(wp), dimension(-offset_x%beg:m + offset_x%end, -offset_y%beg:n + offset_y%end, -offset_z%beg:p + offset_z%end, & + real(wp), dimension(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end, & & 3) :: liutex_axis integer :: i, j, k, l, kx, ky, kz, kf, j_glb, k_glb, l_glb real(wp) :: En_tot @@ -229,7 +229,7 @@ contains if ((model_eqns == 2) .or. (model_eqns == 3) .or. (model_eqns == 4)) 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) + q_sf(:,:,:) = q_cons_vf(i)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) if (model_eqns /= 4) then write (varname, '(A,I0)') 'alpha_rho', i else @@ -243,7 +243,7 @@ contains end if if ((rho_wrt .or. (model_eqns == 1 .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) + 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) + 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) + 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, E_idx - mom_idx%beg if (mom_wrt(i) .or. cons_vars_wrt) then - q_sf(:,:,:) = q_cons_vf(i + cont_idx%end)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(i + cont_idx%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, E_idx - mom_idx%beg if (vel_wrt(i) .or. prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(i + cont_idx%end)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(i + cont_idx%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(chemxb + i - 1)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(chemxb + 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) + 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) @@ -319,7 +319,7 @@ contains end do if (E_wrt .or. cons_vars_wrt) then - q_sf(:,:,:) = q_cons_vf(E_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(E_idx)%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 == 3) then do i = 1, num_fluids if (alpha_rho_e_wrt(i) .or. cons_vars_wrt) then - q_sf = q_cons_vf(i + intxb - 1)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf = q_cons_vf(i + intxb - 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) @@ -445,7 +445,7 @@ contains if (mhd .and. prim_vars_wrt) then do i = B_idx%beg, B_idx%end - q_sf(:,:,:) = q_prim_vf(i)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + 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 @@ -473,7 +473,7 @@ contains if (elasticity) then do i = 1, stress_idx%end - stress_idx%beg + 1 if (prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(i - 1 + stress_idx%beg)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(i - 1 + stress_idx%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 @@ -484,7 +484,7 @@ contains if (hyperelasticity) then do i = 1, xiend - xibeg + 1 if (prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(i - 1 + xibeg)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(i - 1 + xibeg)%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 @@ -493,7 +493,7 @@ contains end if if (cont_damage) then - q_sf(:,:,:) = q_cons_vf(damage_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(damage_idx)%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) @@ -501,7 +501,7 @@ contains end if if (hyper_cleaning) then - q_sf = q_cons_vf(psi_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf = q_cons_vf(psi_idx)%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) @@ -509,7 +509,7 @@ contains end if if (pres_wrt .or. prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(E_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_prim_vf(E_idx)%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) @@ -519,7 +519,7 @@ contains if (((model_eqns == 2) .and. (bubbles_euler .neqv. .true.)) .or. (model_eqns == 3)) 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 + E_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(i + E_idx)%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) @@ -540,7 +540,7 @@ contains end do end do else - q_sf(:,:,:) = q_cons_vf(adv_idx%end)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(adv_idx%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) @@ -550,7 +550,7 @@ contains end if if (gamma_wrt .or. (model_eqns == 1 .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) + 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) @@ -567,7 +567,7 @@ contains end if if (pi_inf_wrt .or. (model_eqns == 1 .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) + 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) @@ -621,7 +621,7 @@ 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, & + 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) @@ -647,7 +647,7 @@ contains varname(:) = ' ' do i = 1, 3 - q_sf = liutex_axis(:,:,:, i) + q_sf = liutex_axis(:,:,:,i) write (varname, '(A,I0)') 'liutex_axis', i call s_write_variable_to_formatted_database_file(varname, t_step) @@ -666,7 +666,7 @@ contains end if if (cf_wrt) then - q_sf(:,:,:) = q_cons_vf(c_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(c_idx)%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(:) = ' ' @@ -674,7 +674,7 @@ contains if (bubbles_euler) then do i = adv_idx%beg, adv_idx%end - q_sf(:,:,:) = q_cons_vf(i)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + 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 - E_idx call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -684,7 +684,7 @@ contains if (bubbles_euler) then ! nR do i = 1, nb - q_sf(:,:,:) = q_cons_vf(bub_idx%rs(i))%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(bub_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(:) = ' ' @@ -692,7 +692,7 @@ contains ! nRdot do i = 1, nb - q_sf(:,:,:) = q_cons_vf(bub_idx%vs(i))%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(bub_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(:) = ' ' @@ -700,7 +700,7 @@ contains if ((polytropic .neqv. .true.) .and. (.not. qbmm)) then ! nP do i = 1, nb - q_sf(:,:,:) = q_cons_vf(bub_idx%ps(i))%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(bub_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(:) = ' ' @@ -708,7 +708,7 @@ contains ! nM do i = 1, nb - q_sf(:,:,:) = q_cons_vf(bub_idx%ms(i))%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(bub_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(:) = ' ' @@ -717,7 +717,7 @@ contains ! number density if (adv_n) then - q_sf(:,:,:) = q_cons_vf(n_idx)%sf(x_beg:x_end, y_beg:y_end, z_beg:z_end) + q_sf(:,:,:) = q_cons_vf(n_idx)%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(:) = ' ' @@ -726,7 +726,7 @@ 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, & + 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) diff --git a/src/pre_process/m_assign_variables.fpp b/src/pre_process/m_assign_variables.fpp index e47c05da1d..e171097d4b 100644 --- a/src/pre_process/m_assign_variables.fpp +++ b/src/pre_process/m_assign_variables.fpp @@ -20,8 +20,7 @@ module m_assign_variables type(scalar_field) :: alf_sum - !> Depending on the multicomponent flow model, this variable is a pointer to either the subroutine - !! s_assign_patch_mixture_primitive_variables, or the subroutine s_assign_patch_species_primitive_variables + !> Pointer to mixture or species patch assignment routine procedure(s_assign_patch_xxxxx_primitive_variables), pointer :: s_assign_patch_primitive_variables => null() !> Abstract interface to the two subroutines that assign the patch primitive variables, either mixture or species, depending on !! the subroutine, to a particular cell in the computational domain @@ -38,9 +37,9 @@ module m_assign_variables type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif end subroutine s_assign_patch_xxxxx_primitive_variables @@ -56,7 +55,7 @@ contains impure subroutine s_initialize_assign_variables_module if (.not. igr) then - allocate (alf_sum%sf(0:m, 0:n, 0:p)) + allocate (alf_sum%sf(0:m,0:n,0:p)) end if ! Select procedure pointer based on multicomponent flow model @@ -83,9 +82,9 @@ contains real(wp), intent(in) :: eta type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif real(wp) :: Ys(1:num_species) @@ -215,9 +214,9 @@ contains integer, intent(in) :: j, k, l real(wp), intent(in) :: eta #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index 3e14ac06c3..70c3485a12 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -26,9 +26,9 @@ contains !> Apply a line-segment boundary condition patch along a domain edge in 2D. impure subroutine s_line_segment_bc(patch_id, bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - integer, intent(in) :: patch_id - integer :: j + type(integer_field), dimension(1:num_dims,1:2), intent(inout) :: bc_type + integer, intent(in) :: patch_id + integer :: j ! Patch is a line segment along y on the x-boundary face @@ -76,9 +76,9 @@ contains !> Apply a circular boundary condition patch on a domain face in 3D. impure subroutine s_circle_bc(patch_id, bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - integer, intent(in) :: patch_id - integer :: j, k + type(integer_field), dimension(1:num_dims,1:2), intent(inout) :: bc_type + integer, intent(in) :: patch_id + integer :: j, k if (patch_bc(patch_id)%dir == 1) then y_centroid = patch_bc(patch_id)%centroid(2) @@ -136,9 +136,9 @@ contains !> Apply a rectangular boundary condition patch on a domain face in 3D. impure subroutine s_rectangle_bc(patch_id, bc_type) - type(integer_field), dimension(1:num_dims, 1:2), intent(inout) :: bc_type - integer, intent(in) :: patch_id - integer :: j, k + type(integer_field), dimension(1:num_dims,1:2), intent(inout) :: bc_type + integer, intent(in) :: patch_id + integer :: j, k if (patch_bc(patch_id)%dir == 1) then y_centroid = patch_bc(patch_id)%centroid(2) @@ -220,9 +220,9 @@ contains !> Iterate over all boundary condition patches and dispatch them by geometry type. impure subroutine s_apply_boundary_patches(q_prim_vf, bc_type) - type(scalar_field), dimension(sys_size) :: q_prim_vf - type(integer_field), dimension(1:num_dims, 1:2) :: bc_type - integer :: i + type(scalar_field), dimension(sys_size) :: q_prim_vf + type(integer_field), dimension(1:num_dims,1:2) :: bc_type + integer :: i !> Apply 2D patches to 3D domain diff --git a/src/pre_process/m_data_output.fpp b/src/pre_process/m_data_output.fpp index c90b7f4661..ab3257a77b 100644 --- a/src/pre_process/m_data_output.fpp +++ b/src/pre_process/m_data_output.fpp @@ -37,8 +37,8 @@ module m_data_output import :: scalar_field, integer_field, sys_size, m, n, p, pres_field, num_dims - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf - type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf + type(integer_field), dimension(1:num_dims,-1:1), intent(in) :: bc_type end subroutine s_write_abstract_data_files end interface @@ -53,22 +53,22 @@ contains !> Writes grid and initial condition data files to the "0" time-step directory in the local processor rank folder impure subroutine s_write_serial_data_files(q_cons_vf, q_prim_vf, bc_type) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf - type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type - logical :: file_exist - character(LEN=15) :: FMT - character(LEN=3) :: status - character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num - character(LEN=len_trim(t_step_dir) + name_len) :: file_loc - integer :: i, j, k, l, r, c - integer :: t_step - real(wp), dimension(nb) :: nRtmp - real(wp) :: nbub - real(wp) :: gamma, lit_gamma, pi_inf, qv - real(wp) :: rho - real(wp) :: pres, T - real(wp) :: rhoYks(1:num_species) - real(wp) :: pres_mag + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf + type(integer_field), dimension(1:num_dims,-1:1), intent(in) :: bc_type + logical :: file_exist + character(LEN=15) :: FMT + character(LEN=3) :: status + character(LEN=int(floor(log10(real(sys_size, wp)))) + 1) :: file_num + character(LEN=len_trim(t_step_dir) + name_len) :: file_loc + integer :: i, j, k, l, r, c + integer :: t_step + real(wp), dimension(nb) :: nRtmp + real(wp) :: nbub + real(wp) :: gamma, lit_gamma, pi_inf, qv + real(wp) :: rho + real(wp) :: pres, T + real(wp) :: rhoYks(1:num_species) + real(wp) :: pres_mag pres_mag = 0._wp @@ -113,7 +113,7 @@ contains write (file_num, '(I0)') i file_loc = trim(t_step_dir) // '/q_cons_vf' // trim(file_num) // '.dat' open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) - write (1) q_cons_vf(i)%sf(0:m, 0:n, 0:p) + write (1) q_cons_vf(i)%sf(0:m,0:n,0:p) close (1) end do @@ -123,7 +123,7 @@ contains write (file_num, '(I0)') r + (i - 1)*nnode + sys_size file_loc = trim(t_step_dir) // '/pb' // trim(file_num) // '.dat' open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) - write (1) pb%sf(:,:,:, r, i) + write (1) pb%sf(:,:,:,r, i) close (1) end do end do @@ -133,7 +133,7 @@ contains write (file_num, '(I0)') r + (i - 1)*nnode + sys_size file_loc = trim(t_step_dir) // '/mv' // trim(file_num) // '.dat' open (1, FILE=trim(file_loc), form='unformatted', STATUS=status) - write (1) mv%sf(:,:,:, r, i) + write (1) mv%sf(:,:,:,r, i) close (1) end do end do @@ -382,8 +382,8 @@ contains !> Writes grid and initial condition data files in parallel to the "0" time-step directory in the local processor rank folder impure subroutine s_write_parallel_data_files(q_cons_vf, q_prim_vf, bc_type) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf - type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf, q_prim_vf + type(integer_field), dimension(1:num_dims,-1:1), intent(in) :: bc_type #ifdef MFC_MPI integer :: ifile, ierr, data_size @@ -399,7 +399,7 @@ contains real(wp) :: loc_violations, glb_violations integer :: m_ds, n_ds, p_ds integer :: m_glb_ds, n_glb_ds, p_glb_ds - integer :: m_glb_save, n_glb_save, p_glb_save ! Size of array being saved + integer :: m_glb_save, n_glb_save, p_glb_save !< Size of array being saved loc_violations = 0._wp @@ -659,7 +659,7 @@ contains allocate (q_cons_temp(1:sys_size)) do i = 1, sys_size - allocate (q_cons_temp(i)%sf(-1:m_ds + 1, -1:n_ds + 1, -1:p_ds + 1)) + allocate (q_cons_temp(i)%sf(-1:m_ds + 1,-1:n_ds + 1,-1:p_ds + 1)) end do end if diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index 73820a165e..077262aece 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -103,28 +103,24 @@ module m_global_parameters type(int_bounds_info) :: idwint(1:3) ! Cell indices (InDices With BUFFer): includes buffer except in pre_process - type(int_bounds_info) :: idwbuff(1:3) - type(int_bounds_info) :: bc_x, bc_y, bc_z !< Boundary conditions in the x-, y- and z-coordinate directions - integer :: shear_num !< Number of shear stress components - integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions - !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, - !! [indices]) - integer, dimension(3, 2) :: shear_BC_flip_indices - logical :: parallel_io !< Format of the data files - logical :: file_per_process !< type of data output - integer :: precision !< Precision of output files - logical :: down_sample !< Down-sample the output data - logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile - real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile - logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow - integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag - !> Peak wavenumber of prescribed energy spectra with mixlayer_perturb flag Default value (k0 = 0.4446) is most unstable mode - !! obtained from linear stability analysis See Michalke (1964, JFM) for details - real(wp) :: mixlayer_perturb_k0 + type(int_bounds_info) :: idwbuff(1:3) + type(int_bounds_info) :: bc_x, bc_y, bc_z !< Boundary conditions in the x-, y- and z-coordinate directions + integer :: shear_num !< Number of shear stress components + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + integer, dimension(3, 2) :: shear_BC_flip_indices !< Shear stress BC reflection indices (1:3, 1:shear_BC_flip_num) + logical :: parallel_io !< Format of the data files + logical :: file_per_process !< type of data output + integer :: precision !< Precision of output files + logical :: down_sample !< Down-sample the output data + logical :: mixlayer_vel_profile !< Set hyperbolic tangent streamwise velocity profile + real(wp) :: mixlayer_vel_coef !< Coefficient for the hyperbolic tangent streamwise velocity profile + logical :: mixlayer_perturb !< Superimpose instability waves to surrounding fluid flow + integer :: mixlayer_perturb_nk !< Number of Fourier modes for perturbation with mixlayer_perturb flag + real(wp) :: mixlayer_perturb_k0 !< Peak wavenumber for mixlayer perturbation (default: most unstable mode) logical :: simplex_perturb type(simplex_noise_params) :: simplex_params - real(wp) :: pi_fac !< Factor for artificial pi_inf + real(wp) :: pi_fac !< Factor for artificial pi_inf logical :: viscous logical :: bubbles_lagrange @@ -146,19 +142,14 @@ module m_global_parameters #endif ! Initial Condition Parameters - integer :: num_patches !< Number of patches composing initial condition - !> Database of the initial condition patch parameters (icpp) for each of the patches employed in the configuration of the - !! initial condition. Note that the maximum allowable number of patches, num_patches_max, may be changed in the module - !! m_derived_types.f90. - type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp + integer :: num_patches !< Number of patches composing initial condition + type(ic_patch_parameters), dimension(num_patches_max) :: patch_icpp !< IC patch parameters (max: num_patches_max) integer :: num_bc_patches !< Number of boundary condition patches logical :: bc_io !< whether or not to save BC data type(bc_patch_parameters), dimension(num_bc_patches_max) :: patch_bc !< Boundary condition patch parameters ! Fluids Physical Parameters - !> Database of the physical parameters of each of the fluids that is present in the flow. These include the stiffened gas - !! equation of state parameters, and the Reynolds numbers. - type(physical_parameters), dimension(num_fluids_max) :: fluid_pp + type(physical_parameters), dimension(num_fluids_max) :: fluid_pp !< Stiffened gas EOS parameters and Reynolds numbers per fluid ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp real(wp) :: rhoref, pref !< Reference parameters for Tait EOS @@ -189,8 +180,8 @@ module m_global_parameters logical :: polytropic logical :: polydisperse real(wp) :: poly_sigma - integer :: dist_type ! 1 = binormal, 2 = lognormal-normal - integer :: thermal ! 1 = adiabatic, 2 = isotherm, 3 = transfer + integer :: dist_type !< 1 = binormal, 2 = lognormal-normal + integer :: thermal !< 1 = adiabatic, 2 = isotherm, 3 = transfer real(wp) :: phi_vg, phi_gv, Pe_c, Tw, k_vl, k_gl real(wp) :: gam_m real(wp), dimension(:), allocatable :: pb0, mass_g0, mass_v0, Pe_T, k_v, k_g @@ -219,14 +210,10 @@ module m_global_parameters integer, allocatable, dimension(:,:,:) :: logic_grid type(pres_field) :: pb type(pres_field) :: mv - real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) - !> The number of cells that are necessary to be able to store enough boundary conditions data to march the solution in the - !! physical computational domain to the next time-step. - integer :: buff_size - logical :: fft_wrt - !> AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional - !! is false - logical :: dummy + real(wp) :: Bx0 !< Constant magnetic field in the x-direction (1D) + integer :: buff_size !< Number of ghost cells for boundary condition storage + logical :: fft_wrt + logical :: dummy !< AMDFlang workaround for case-optimization + GPU-kernel bug contains @@ -644,7 +631,7 @@ contains if (qbmm) then allocate (bub_idx%moms(nb, nmom)) - allocate (bub_idx%fullmom(nb, 0:nmom, 0:nmom)) + allocate (bub_idx%fullmom(nb,0:nmom,0:nmom)) do i = 1, nb do j = 1, nmom @@ -771,15 +758,15 @@ contains shear_num = 1 shear_indices(1) = stress_idx%beg - 1 + 2 shear_BC_flip_num = 1 - shear_BC_flip_indices(1:2, 1) = shear_indices(1) + shear_BC_flip_indices(1:2,1) = shear_indices(1) ! Both x-dir and y-dir: flip tau_xy only else if (num_dims == 3) then shear_num = 3 shear_indices(1:3) = stress_idx%beg - 1 + (/2, 4, 5/) shear_BC_flip_num = 2 - shear_BC_flip_indices(1, 1:2) = shear_indices((/1, 2/)) - shear_BC_flip_indices(2, 1:2) = shear_indices((/1, 3/)) - shear_BC_flip_indices(3, 1:2) = shear_indices((/2, 3/)) + shear_BC_flip_indices(1,1:2) = shear_indices((/1, 2/)) + shear_BC_flip_indices(2,1:2) = shear_indices((/1, 3/)) + shear_BC_flip_indices(3,1:2) = shear_indices((/2, 3/)) ! x-dir: flip tau_xy and tau_xz y-dir: flip tau_xy and tau_yz z-dir: flip tau_xz and tau_yz end if end if @@ -847,13 +834,13 @@ contains if (.not. down_sample) then do i = 1, sys_size - allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) + allocate (MPI_IO_DATA%var(i)%sf(0:m,0:n,0:p)) MPI_IO_DATA%var(i)%sf => null() end do end if if (qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode - allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) + allocate (MPI_IO_DATA%var(i)%sf(0:m,0:n,0:p)) MPI_IO_DATA%var(i)%sf => null() end do end if @@ -878,7 +865,7 @@ contains end if if (.not. igr) then - allocate (logic_grid(0:m, 0:n, 0:p)) + allocate (logic_grid(0:m,0:n,0:p)) end if end subroutine s_initialize_global_parameters_module diff --git a/src/pre_process/m_icpp_patches.fpp b/src/pre_process/m_icpp_patches.fpp index 188eb23f9f..a565a1b0b3 100644 --- a/src/pre_process/m_icpp_patches.fpp +++ b/src/pre_process/m_icpp_patches.fpp @@ -27,25 +27,15 @@ module m_icpp_patches private; public :: s_apply_icpp_patches - real(wp) :: x_centroid, y_centroid, z_centroid - real(wp) :: length_x, length_y, length_z - integer :: smooth_patch_id - !> These variables are analogous in both meaning and use to the similarly named components in the ic_patch_parameters type (see - !! m_derived_types.f90 for additional details). They are employed as a means to more concisely perform the actions necessary to - !! lay out a particular patch on the grid. - real(wp) :: smooth_coeff - !> In the case that smoothing of patch boundaries is enabled and the boundary between two adjacent patches is to be smeared out, - !! this variable's purpose is to act as a pseudo volume fraction to indicate the contribution of each patch toward the - !! composition of a cell's fluid state. - real(wp) :: eta - real(wp) :: cart_x, cart_y, cart_z - !> Variables to be used to hold cell locations in Cartesian coordinates if 3D simulation is using cylindrical coordinates - real(wp) :: sph_phi - !> These variables combine the centroid and length parameters associated with a particular patch to yield the locations of the - !! patch boundaries in the x-, y- and z-coordinate directions. They are used as a means to concisely perform the actions - !! necessary to lay out a particular patch on the grid. - type(bounds_info) :: x_boundary, y_boundary, z_boundary - character(len=5) :: istr ! string to store int to string result for error checking + real(wp) :: x_centroid, y_centroid, z_centroid + real(wp) :: length_x, length_y, length_z + integer :: smooth_patch_id + real(wp) :: smooth_coeff !< Smoothing coefficient (mirrors ic_patch_parameters%smooth_coeff) + real(wp) :: eta !< Pseudo volume fraction for patch boundary smoothing + real(wp) :: cart_x, cart_y, cart_z + real(wp) :: sph_phi !< Spherical phi for Cartesian conversion in cylindrical coordinates + type(bounds_info) :: x_boundary, y_boundary, z_boundary !< Patch boundary locations in x, y, z + character(len=5) :: istr !< string to store int to string result for error checking contains @@ -55,9 +45,9 @@ contains type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif integer :: i @@ -170,9 +160,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf @@ -230,9 +220,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators @@ -295,9 +285,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf real(wp) :: radius @@ -349,9 +339,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf @@ -406,9 +396,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf @@ -469,9 +459,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop operators @@ -526,9 +516,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf @@ -598,9 +588,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< generic loop iterators @@ -668,9 +658,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop operators @@ -725,9 +715,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< generic loop iterators @@ -796,9 +786,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf @@ -850,9 +840,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf real(wp) :: r, theta, R_boundary, sum_series @@ -905,9 +895,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf real(wp) :: dx_loc, dy_loc, dz_loc, r, theta, phi, R_surface, eta_local @@ -969,9 +959,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf @@ -1038,9 +1028,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators @@ -1108,9 +1098,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators @@ -1203,9 +1193,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf integer :: i, j, k !< Generic loop iterators @@ -1271,9 +1261,9 @@ contains integer, intent(in) :: patch_id #ifdef MFC_MIXED_PRECISION - integer(kind=1), dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer(kind=1), dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #else - integer, dimension(0:m, 0:n, 0:p), intent(inout) :: patch_id_fp + integer, dimension(0:m,0:n,0:p), intent(inout) :: patch_id_fp #endif type(scalar_field), dimension(1:sys_size), intent(inout) :: q_prim_vf @@ -1288,10 +1278,10 @@ contains type(t_model) :: model type(ic_model_parameters) :: params real(wp), dimension(1:3) :: point, model_center - real(wp) :: grid_mm(1:3, 1:2) + real(wp) :: grid_mm(1:3,1:2) integer :: cell_num integer :: ncells - real(wp), dimension(1:4, 1:4) :: transform, transform_n + real(wp), dimension(1:4,1:4) :: transform, transform_n if (proc_rank == 0) then print *, " * Reading model: " // trim(patch_icpp(patch_id)%model_filepath) @@ -1347,9 +1337,9 @@ contains grid_mm(3,:) = (/0._wp, 0._wp/) end if - write (*, "(A, 3(2X, F20.10))") " > Domain: Min:", grid_mm(:, 1) - write (*, "(A, 3(2X, F20.10))") " > Cen:", (grid_mm(:, 1) + grid_mm(:, 2))/2._wp - write (*, "(A, 3(2X, F20.10))") " > Max:", grid_mm(:, 2) + write (*, "(A, 3(2X, F20.10))") " > Domain: Min:", grid_mm(:,1) + write (*, "(A, 3(2X, F20.10))") " > Cen:", (grid_mm(:,1) + grid_mm(:,2))/2._wp + write (*, "(A, 3(2X, F20.10))") " > Max:", grid_mm(:,2) end if ncells = (m + 1)*(n + 1)*(p + 1) diff --git a/src/pre_process/m_initial_condition.fpp b/src/pre_process/m_initial_condition.fpp index 2d95d7d0d1..0b5a6ba40a 100644 --- a/src/pre_process/m_initial_condition.fpp +++ b/src/pre_process/m_initial_condition.fpp @@ -44,19 +44,19 @@ contains allocate (q_cons_vf(1:sys_size)) do i = 1, sys_size - allocate (q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) - allocate (q_cons_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + allocate (q_prim_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end,idwbuff(3)%beg:idwbuff(3)%end)) + allocate (q_cons_vf(i)%sf(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end,idwbuff(3)%beg:idwbuff(3)%end)) end do if (chemistry) then - allocate (q_T_sf%sf(0:m, 0:n, 0:p)) + allocate (q_T_sf%sf(0:m,0:n,0:p)) end if - allocate (patch_id_fp(0:m, 0:n, 0:p)) + allocate (patch_id_fp(0:m,0:n,0:p)) if (qbmm .and. .not. polytropic) then - allocate (pb%sf(0:m, 0:n, 0:p, 1:nnode, 1:nb)) - allocate (mv%sf(0:m, 0:n, 0:p, 1:nnode, 1:nb)) + allocate (pb%sf(0:m,0:n,0:p,1:nnode,1:nb)) + allocate (mv%sf(0:m,0:n,0:p,1:nnode,1:nb)) end if do i = 1, sys_size @@ -64,10 +64,10 @@ contains q_prim_vf(i)%sf = -1.e-6_stp ! real(dflt_real, kind=stp) end do - allocate (bc_type(1:num_dims, 1:2)) + allocate (bc_type(1:num_dims,1:2)) - allocate (bc_type(1, 1)%sf(0:0, 0:n, 0:p)) - allocate (bc_type(1, 2)%sf(0:0, 0:n, 0:p)) + allocate (bc_type(1, 1)%sf(0:0,0:n,0:p)) + allocate (bc_type(1, 2)%sf(0:0,0:n,0:p)) do l = 0, p do k = 0, n @@ -77,8 +77,8 @@ contains end do if (n > 0) then - allocate (bc_type(2, 1)%sf(-buff_size:m + buff_size, 0:0, 0:p)) - allocate (bc_type(2, 2)%sf(-buff_size:m + buff_size, 0:0, 0:p)) + allocate (bc_type(2, 1)%sf(-buff_size:m + buff_size,0:0,0:p)) + allocate (bc_type(2, 2)%sf(-buff_size:m + buff_size,0:0,0:p)) do l = 0, p do j = -buff_size, m + buff_size @@ -88,8 +88,8 @@ contains end do if (p > 0) then - allocate (bc_type(3, 1)%sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) - allocate (bc_type(3, 2)%sf(-buff_size:m + buff_size, -buff_size:n + buff_size, 0:0)) + allocate (bc_type(3, 1)%sf(-buff_size:m + buff_size,-buff_size:n + buff_size,0:0)) + allocate (bc_type(3, 2)%sf(-buff_size:m + buff_size,-buff_size:n + buff_size,0:0)) do k = -buff_size, n + buff_size do j = -buff_size, m + buff_size diff --git a/src/pre_process/m_perturbation.fpp b/src/pre_process/m_perturbation.fpp index 81afa0b24f..f3096068c1 100644 --- a/src/pre_process/m_perturbation.fpp +++ b/src/pre_process/m_perturbation.fpp @@ -23,7 +23,7 @@ contains impure subroutine s_initialize_perturbation_module() if (elliptic_smoothing) then - allocate (q_prim_temp(0:m, 0:n, 0:p, 1:sys_size)) + allocate (q_prim_temp(0:m,0:n,0:p,1:sys_size)) end if end subroutine s_initialize_perturbation_module @@ -88,9 +88,9 @@ contains !> Iteratively smooth all primitive variable fields using a discrete elliptic (Laplacian) filter. impure subroutine s_elliptic_smoothing(q_prim_vf, bc_type) - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - integer :: i, j, k, l, q + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + integer :: i, j, k, l, q do q = 1, elliptic_smoothing_iters ! Communication of buffer regions and apply boundary conditions diff --git a/src/pre_process/m_start_up.fpp b/src/pre_process/m_start_up.fpp index 51a6f66730..a3a7c51270 100644 --- a/src/pre_process/m_start_up.fpp +++ b/src/pre_process/m_start_up.fpp @@ -59,9 +59,7 @@ module m_start_up end interface character(LEN=path_len + name_len) :: proc_rank_dir !< Location of the folder associated with the rank of the local processor - !> Possible location of time-step folder containing preexisting grid and/or conservative variables data to be used as starting - !! point for pre-process - character(LEN=path_len + 2*name_len), private :: t_step_dir + character(LEN=path_len + 2*name_len), private :: t_step_dir !< Path to preexisting time-step folder for restart procedure(s_read_abstract_grid_data_files), pointer :: s_read_grid_data_files => null() procedure(s_read_abstract_ic_data_files), pointer :: s_read_ic_data_files => null() @@ -294,7 +292,7 @@ contains if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') - read (1) pb%sf(:,:,:, r, i) + read (1) pb%sf(:,:,:,r, i) close (1) else call s_mpi_abort('File pb' // trim(file_num) // '.dat is missing in ' // trim(t_step_dir) // '. Exiting.') @@ -310,7 +308,7 @@ contains if (file_check) then open (1, FILE=trim(file_loc), form='unformatted', STATUS='old', ACTION='read') - read (1) mv%sf(:,:,:, r, i) + read (1) mv%sf(:,:,:,r, i) close (1) else call s_mpi_abort('File mv' // trim(file_num) // '.dat is missing in ' // trim(t_step_dir) // '. Exiting.') diff --git a/src/simulation/m_acoustic_src.fpp b/src/simulation/m_acoustic_src.fpp index c982ffbd62..41c897cfd3 100644 --- a/src/simulation/m_acoustic_src.fpp +++ b/src/simulation/m_acoustic_src.fpp @@ -13,7 +13,9 @@ module m_acoustic_src use m_variables_conversion use m_helper_basic use m_constants + implicit none + private; public :: s_initialize_acoustic_src, s_precalculate_acoustic_spatial_sources, s_acoustic_src_calculations integer, allocatable, dimension(:) :: pulse, support @@ -336,9 +338,9 @@ contains real(wp), intent(in) :: sim_time, c, sum_BB real(wp), intent(in) :: frequency_local, gauss_sigma_time_local real(wp), intent(out) :: source - real(wp) :: omega ! angular frequency - real(wp) :: sine_wave ! sine function for square wave - real(wp) :: foc_length_factor ! Scale amplitude with radius for spherical support + real(wp) :: omega !< angular frequency + real(wp) :: sine_wave !< sine function for square wave + real(wp) :: foc_length_factor !< Scale amplitude with radius for spherical support ! i.e. Spherical support -> 1/r scaling; Cylindrical support -> 1/sqrt(r) [empirical correction: ^-0.5 -> ^-0.85] integer, parameter :: mass_label = 1 @@ -412,7 +414,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - call s_source_spatial(j, k, l, loc_acoustic(:, ai), ai, source_spatial, angle, xyz_to_r_ratios) + call s_source_spatial(j, k, l, loc_acoustic(:,ai), ai, source_spatial, angle, xyz_to_r_ratios) if (abs(source_spatial) < threshold) cycle count = count + 1 end do @@ -434,7 +436,7 @@ contains do l = 0, p do k = 0, n do j = 0, m - call s_source_spatial(j, k, l, loc_acoustic(:, ai), ai, source_spatial, angle, xyz_to_r_ratios) + call s_source_spatial(j, k, l, loc_acoustic(:,ai), ai, source_spatial, angle, xyz_to_r_ratios) if (abs(source_spatial) < threshold) cycle count = count + 1 source_spatials(ai)%coord(1, count) = j @@ -443,7 +445,7 @@ contains source_spatials(ai)%val(count) = source_spatial if (support(ai) >= 5) then if (dim == 2) source_spatials(ai)%angle(count) = angle - if (dim == 3) source_spatials(ai)%xyz_to_r_ratios(1:3, count) = xyz_to_r_ratios + if (dim == 3) source_spatials(ai)%xyz_to_r_ratios(1:3,count) = xyz_to_r_ratios end if end do end do diff --git a/src/simulation/m_bubbles.fpp b/src/simulation/m_bubbles.fpp index ae9faaa2cf..2ff5952827 100644 --- a/src/simulation/m_bubbles.fpp +++ b/src/simulation/m_bubbles.fpp @@ -13,6 +13,7 @@ module m_bubbles use m_mpi_proxy use m_variables_conversion use m_helper_basic + implicit none real(wp) :: chi_vw !< Bubble wall properties (Ando 2010) diff --git a/src/simulation/m_bubbles_EE.fpp b/src/simulation/m_bubbles_EE.fpp index 8f3ae8fdab..b2c5f1fd97 100644 --- a/src/simulation/m_bubbles_EE.fpp +++ b/src/simulation/m_bubbles_EE.fpp @@ -12,6 +12,7 @@ module m_bubbles_EE use m_mpi_proxy use m_variables_conversion use m_bubbles + implicit none real(wp), allocatable, dimension(:,:,:) :: bub_adv_src diff --git a/src/simulation/m_bubbles_EL.fpp b/src/simulation/m_bubbles_EL.fpp index 92153d91ab..437dbe0db2 100644 --- a/src/simulation/m_bubbles_EL.fpp +++ b/src/simulation/m_bubbles_EL.fpp @@ -245,19 +245,19 @@ contains bub_dphidt(bub_id) = 0._wp intfc_rad(bub_id, 1) = inputBubble(7) intfc_vel(bub_id, 1) = inputBubble(8) - mtn_pos(bub_id, 1:3, 1) = inputBubble(1:3) - mtn_posPrev(bub_id, 1:3, 1) = mtn_pos(bub_id, 1:3, 1) - mtn_vel(bub_id, 1:3, 1) = inputBubble(4:6) + mtn_pos(bub_id,1:3,1) = inputBubble(1:3) + mtn_posPrev(bub_id,1:3,1) = mtn_pos(bub_id,1:3,1) + mtn_vel(bub_id,1:3,1) = inputBubble(4:6) if (cyl_coord .and. p == 0) then mtn_pos(bub_id, 2, 1) = sqrt(mtn_pos(bub_id, 2, 1)**2._wp + mtn_pos(bub_id, 3, 1)**2._wp) ! Storing azimuthal angle (-Pi to Pi)) into the third coordinate variable mtn_pos(bub_id, 3, 1) = atan2(inputBubble(3), inputBubble(2)) - mtn_posPrev(bub_id, 1:3, 1) = mtn_pos(bub_id, 1:3, 1) + mtn_posPrev(bub_id,1:3,1) = mtn_pos(bub_id,1:3,1) end if cell = -buff_size - call s_locate_cell(mtn_pos(bub_id, 1:3, 1), cell, mtn_s(bub_id, 1:3, 1)) + call s_locate_cell(mtn_pos(bub_id,1:3,1), cell, mtn_s(bub_id,1:3,1)) ! Check if the bubble is located in the ghost cell of a symmetric, or wall boundary if ((any(bc_x%beg == (/BC_REFLECTIVE, BC_CHAR_SLIP_WALL, BC_SLIP_WALL, & @@ -338,17 +338,17 @@ contains integer :: file_num_procs, file_tot_part, tot_part #ifdef MFC_MPI - real(wp), dimension(20) :: inputvals - integer, dimension(MPI_STATUS_SIZE) :: status - integer(kind=MPI_OFFSET_KIND) :: disp - integer :: view - integer, dimension(3) :: cell - logical :: indomain, particle_file, file_exist - integer, dimension(2) :: gsizes, lsizes, start_idx_part - integer :: ifile, ierr, tot_data, id - integer :: i - integer, dimension(:), allocatable :: proc_bubble_counts - real(wp), dimension(1:1, 1:lag_io_vars) :: dummy + real(wp), dimension(20) :: inputvals + integer, dimension(MPI_STATUS_SIZE) :: status + integer(kind=MPI_OFFSET_KIND) :: disp + integer :: view + integer, dimension(3) :: cell + logical :: indomain, particle_file, file_exist + integer, dimension(2) :: gsizes, lsizes, start_idx_part + integer :: ifile, ierr, tot_data, id + integer :: i + integer, dimension(:), allocatable :: proc_bubble_counts + real(wp), dimension(1:1,1:lag_io_vars) :: dummy dummy = 0._wp @@ -414,7 +414,7 @@ contains gsizes(2) = lag_io_vars if (bub_id > 0) then - allocate (MPI_IO_DATA_lag_bubbles(bub_id, 1:lag_io_vars)) + allocate (MPI_IO_DATA_lag_bubbles(bub_id,1:lag_io_vars)) call MPI_TYPE_CREATE_SUBARRAY(2, gsizes, lsizes, start_idx_part, MPI_ORDER_FORTRAN, mpi_p, view, ierr) call MPI_TYPE_COMMIT(view, ierr) @@ -435,9 +435,9 @@ contains do i = 1, bub_id lag_id(i, 1) = int(MPI_IO_DATA_lag_bubbles(i, 1)) - mtn_pos(i, 1:3, 1) = MPI_IO_DATA_lag_bubbles(i, 2:4) - mtn_posPrev(i, 1:3, 1) = MPI_IO_DATA_lag_bubbles(i, 5:7) - mtn_vel(i, 1:3, 1) = MPI_IO_DATA_lag_bubbles(i, 8:10) + mtn_pos(i,1:3,1) = MPI_IO_DATA_lag_bubbles(i,2:4) + mtn_posPrev(i,1:3,1) = MPI_IO_DATA_lag_bubbles(i,5:7) + mtn_vel(i,1:3,1) = MPI_IO_DATA_lag_bubbles(i,8:10) intfc_rad(i, 1) = MPI_IO_DATA_lag_bubbles(i, 11) intfc_vel(i, 1) = MPI_IO_DATA_lag_bubbles(i, 12) bub_R0(i) = MPI_IO_DATA_lag_bubbles(i, 13) @@ -450,7 +450,7 @@ contains gas_betaT(i) = MPI_IO_DATA_lag_bubbles(i, 20) gas_betaC(i) = MPI_IO_DATA_lag_bubbles(i, 21) cell = -buff_size - call s_locate_cell(mtn_pos(i, 1:3, 1), cell, mtn_s(i, 1:3, 1)) + call s_locate_cell(mtn_pos(i,1:3,1), cell, mtn_s(i,1:3,1)) end do deallocate (MPI_IO_DATA_lag_bubbles) @@ -782,7 +782,7 @@ contains integer :: smearGrid, smearGridz logical :: celloutside - scoord = mtn_s(bub_id, 1:3, 2) + scoord = mtn_s(bub_id,1:3,2) f_pinfl = 0._wp !> Find current bubble cell @@ -978,8 +978,8 @@ contains ! u{1} = u{n} + dt * RHS{n} intfc_rad(k, 1) = intfc_rad(k, 1) + dt*intfc_draddt(k, 1) intfc_vel(k, 1) = intfc_vel(k, 1) + dt*intfc_dveldt(k, 1) - mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + dt*mtn_dposdt(k, 1:3, 1) - mtn_vel(k, 1:3, 1) = mtn_vel(k, 1:3, 1) + dt*mtn_dveldt(k, 1:3, 1) + mtn_pos(k,1:3,1) = mtn_pos(k,1:3,1) + dt*mtn_dposdt(k,1:3,1) + mtn_vel(k,1:3,1) = mtn_vel(k,1:3,1) + dt*mtn_dveldt(k,1:3,1) gas_p(k, 1) = gas_p(k, 1) + dt*gas_dpdt(k, 1) gas_mv(k, 1) = gas_mv(k, 1) + dt*gas_dmvdt(k, 1) end do @@ -1000,8 +1000,8 @@ contains ! u{1} = u{n} + dt * RHS{n} intfc_rad(k, 2) = intfc_rad(k, 1) + dt*intfc_draddt(k, 1) intfc_vel(k, 2) = intfc_vel(k, 1) + dt*intfc_dveldt(k, 1) - mtn_pos(k, 1:3, 2) = mtn_pos(k, 1:3, 1) + dt*mtn_dposdt(k, 1:3, 1) - mtn_vel(k, 1:3, 2) = mtn_vel(k, 1:3, 1) + dt*mtn_dveldt(k, 1:3, 1) + mtn_pos(k,1:3,2) = mtn_pos(k,1:3,1) + dt*mtn_dposdt(k,1:3,1) + mtn_vel(k,1:3,2) = mtn_vel(k,1:3,1) + dt*mtn_dveldt(k,1:3,1) gas_p(k, 2) = gas_p(k, 1) + dt*gas_dpdt(k, 1) gas_mv(k, 2) = gas_mv(k, 1) + dt*gas_dmvdt(k, 1) end do @@ -1012,8 +1012,8 @@ contains ! u{1} = u{n} + (1/2) * dt * (RHS{n} + RHS{1}) intfc_rad(k, 1) = intfc_rad(k, 1) + dt*(intfc_draddt(k, 1) + intfc_draddt(k, 2))/2._wp intfc_vel(k, 1) = intfc_vel(k, 1) + dt*(intfc_dveldt(k, 1) + intfc_dveldt(k, 2))/2._wp - mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + dt*(mtn_dposdt(k, 1:3, 1) + mtn_dposdt(k, 1:3, 2))/2._wp - mtn_vel(k, 1:3, 1) = mtn_vel(k, 1:3, 1) + dt*(mtn_dveldt(k, 1:3, 1) + mtn_dveldt(k, 1:3, 2))/2._wp + mtn_pos(k,1:3,1) = mtn_pos(k,1:3,1) + dt*(mtn_dposdt(k,1:3,1) + mtn_dposdt(k,1:3,2))/2._wp + mtn_vel(k,1:3,1) = mtn_vel(k,1:3,1) + dt*(mtn_dveldt(k,1:3,1) + mtn_dveldt(k,1:3,2))/2._wp gas_p(k, 1) = gas_p(k, 1) + dt*(gas_dpdt(k, 1) + gas_dpdt(k, 2))/2._wp gas_mv(k, 1) = gas_mv(k, 1) + dt*(gas_dmvdt(k, 1) + gas_dmvdt(k, 2))/2._wp end do @@ -1035,8 +1035,8 @@ contains ! u{1} = u{n} + dt * RHS{n} intfc_rad(k, 2) = intfc_rad(k, 1) + dt*intfc_draddt(k, 1) intfc_vel(k, 2) = intfc_vel(k, 1) + dt*intfc_dveldt(k, 1) - mtn_pos(k, 1:3, 2) = mtn_pos(k, 1:3, 1) + dt*mtn_dposdt(k, 1:3, 1) - mtn_vel(k, 1:3, 2) = mtn_vel(k, 1:3, 1) + dt*mtn_dveldt(k, 1:3, 1) + mtn_pos(k,1:3,2) = mtn_pos(k,1:3,1) + dt*mtn_dposdt(k,1:3,1) + mtn_vel(k,1:3,2) = mtn_vel(k,1:3,1) + dt*mtn_dveldt(k,1:3,1) gas_p(k, 2) = gas_p(k, 1) + dt*gas_dpdt(k, 1) gas_mv(k, 2) = gas_mv(k, 1) + dt*gas_dmvdt(k, 1) end do @@ -1047,8 +1047,8 @@ contains ! u{2} = u{n} + (1/4) * dt * [RHS{n} + RHS{1}] intfc_rad(k, 2) = intfc_rad(k, 1) + dt*(intfc_draddt(k, 1) + intfc_draddt(k, 2))/4._wp intfc_vel(k, 2) = intfc_vel(k, 1) + dt*(intfc_dveldt(k, 1) + intfc_dveldt(k, 2))/4._wp - mtn_pos(k, 1:3, 2) = mtn_pos(k, 1:3, 1) + dt*(mtn_dposdt(k, 1:3, 1) + mtn_dposdt(k, 1:3, 2))/4._wp - mtn_vel(k, 1:3, 2) = mtn_vel(k, 1:3, 1) + dt*(mtn_dveldt(k, 1:3, 1) + mtn_dveldt(k, 1:3, 2))/4._wp + mtn_pos(k,1:3,2) = mtn_pos(k,1:3,1) + dt*(mtn_dposdt(k,1:3,1) + mtn_dposdt(k,1:3,2))/4._wp + mtn_vel(k,1:3,2) = mtn_vel(k,1:3,1) + dt*(mtn_dveldt(k,1:3,1) + mtn_dveldt(k,1:3,2))/4._wp gas_p(k, 2) = gas_p(k, 1) + dt*(gas_dpdt(k, 1) + gas_dpdt(k, 2))/4._wp gas_mv(k, 2) = gas_mv(k, 1) + dt*(gas_dmvdt(k, 1) + gas_dmvdt(k, 2))/4._wp end do @@ -1061,10 +1061,10 @@ contains & 2)/4._wp + intfc_draddt(k, 3)) intfc_vel(k, 1) = intfc_vel(k, 1) + (2._wp/3._wp)*dt*(intfc_dveldt(k, 1)/4._wp + intfc_dveldt(k, & & 2)/4._wp + intfc_dveldt(k, 3)) - mtn_pos(k, 1:3, 1) = mtn_pos(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dposdt(k, 1:3, 1)/4._wp + mtn_dposdt(k, 1:3, & - & 2)/4._wp + mtn_dposdt(k, 1:3, 3)) - mtn_vel(k, 1:3, 1) = mtn_vel(k, 1:3, 1) + (2._wp/3._wp)*dt*(mtn_dveldt(k, 1:3, 1)/4._wp + mtn_dveldt(k, 1:3, & - & 2)/4._wp + mtn_dveldt(k, 1:3, 3)) + mtn_pos(k,1:3,1) = mtn_pos(k,1:3,1) + (2._wp/3._wp)*dt*(mtn_dposdt(k,1:3,1)/4._wp + mtn_dposdt(k,1:3, & + & 2)/4._wp + mtn_dposdt(k,1:3,3)) + mtn_vel(k,1:3,1) = mtn_vel(k,1:3,1) + (2._wp/3._wp)*dt*(mtn_dveldt(k,1:3,1)/4._wp + mtn_dveldt(k,1:3, & + & 2)/4._wp + mtn_dveldt(k,1:3,3)) gas_p(k, 1) = gas_p(k, 1) + (2._wp/3._wp)*dt*(gas_dpdt(k, 1)/4._wp + gas_dpdt(k, 2)/4._wp + gas_dpdt(k, 3)) gas_mv(k, 1) = gas_mv(k, 1) + (2._wp/3._wp)*dt*(gas_dmvdt(k, 1)/4._wp + gas_dmvdt(k, 2)/4._wp + gas_dmvdt(k, 3)) end do @@ -1143,10 +1143,10 @@ contains gas_mv(k, 2) = gas_mv(k, 1) intfc_rad(k, 2) = intfc_rad(k, 1) intfc_vel(k, 2) = intfc_vel(k, 1) - mtn_pos(k, 1:3, 2) = mtn_pos(k, 1:3, 1) - mtn_posPrev(k, 1:3, 2) = mtn_posPrev(k, 1:3, 1) - mtn_vel(k, 1:3, 2) = mtn_vel(k, 1:3, 1) - mtn_s(k, 1:3, 2) = mtn_s(k, 1:3, 1) + mtn_pos(k,1:3,2) = mtn_pos(k,1:3,1) + mtn_posPrev(k,1:3,2) = mtn_posPrev(k,1:3,1) + mtn_vel(k,1:3,2) = mtn_vel(k,1:3,1) + mtn_s(k,1:3,2) = mtn_s(k,1:3,1) end do $:END_GPU_PARALLEL_LOOP() @@ -1223,9 +1223,9 @@ contains !> Compute the gradient of a scalar field using second-order central differences on a non-uniform grid subroutine s_gradient_dir(q, dq, dir) - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:), intent(inout) :: q, dq - integer, intent(in) :: dir - integer :: i, j, k + real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:), intent(inout) :: q, dq + integer, intent(in) :: dir + integer :: i, j, k if (dir == 1) then ! Gradient in x dir. @@ -1388,20 +1388,20 @@ contains #ifdef MFC_MPI ! For Parallel I/O - integer :: ifile, ierr - integer, dimension(MPI_STATUS_SIZE) :: status - integer(KIND=MPI_OFFSET_KIND) :: disp - integer :: view - integer, dimension(2) :: gsizes, lsizes, start_idx_part - integer, allocatable :: proc_bubble_counts(:) - real(wp), dimension(1:1, 1:lag_io_vars) :: dummy + integer :: ifile, ierr + integer, dimension(MPI_STATUS_SIZE) :: status + integer(KIND=MPI_OFFSET_KIND) :: disp + integer :: view + integer, dimension(2) :: gsizes, lsizes, start_idx_part + integer, allocatable :: proc_bubble_counts(:) + real(wp), dimension(1:1,1:lag_io_vars) :: dummy dummy = 0._wp bub_id = 0._wp if (nBubs /= 0) then do k = 1, nBubs - if (particle_in_domain_physical(mtn_pos(k, 1:3, 1))) then + if (particle_in_domain_physical(mtn_pos(k,1:3,1))) then bub_id = bub_id + 1 end if end do @@ -1456,15 +1456,15 @@ contains call MPI_BARRIER(MPI_COMM_WORLD, ierr) if (bub_id > 0) then - allocate (MPI_IO_DATA_lag_bubbles(max(1, bub_id), 1:lag_io_vars)) + allocate (MPI_IO_DATA_lag_bubbles(max(1, bub_id),1:lag_io_vars)) i = 1 do k = 1, nBubs - if (particle_in_domain_physical(mtn_pos(k, 1:3, 1))) then + if (particle_in_domain_physical(mtn_pos(k,1:3,1))) then MPI_IO_DATA_lag_bubbles(i, 1) = real(lag_id(k, 1)) - MPI_IO_DATA_lag_bubbles(i, 2:4) = mtn_pos(k, 1:3, 1) - MPI_IO_DATA_lag_bubbles(i, 5:7) = mtn_posPrev(k, 1:3, 1) - MPI_IO_DATA_lag_bubbles(i, 8:10) = mtn_vel(k, 1:3, 1) + MPI_IO_DATA_lag_bubbles(i,2:4) = mtn_pos(k,1:3,1) + MPI_IO_DATA_lag_bubbles(i,5:7) = mtn_posPrev(k,1:3,1) + MPI_IO_DATA_lag_bubbles(i,8:10) = mtn_vel(k,1:3,1) MPI_IO_DATA_lag_bubbles(i, 11) = intfc_rad(k, 1) MPI_IO_DATA_lag_bubbles(i, 12) = intfc_vel(k, 1) MPI_IO_DATA_lag_bubbles(i, 13) = bub_R0(k) @@ -1585,18 +1585,18 @@ contains gas_betaT(i) = gas_betaT(i + 1) gas_betaC(i) = gas_betaC(i + 1) bub_dphidt(i) = bub_dphidt(i + 1) - gas_p(i, 1:2) = gas_p(i + 1, 1:2) - gas_mv(i, 1:2) = gas_mv(i + 1, 1:2) - intfc_rad(i, 1:2) = intfc_rad(i + 1, 1:2) - intfc_vel(i, 1:2) = intfc_vel(i + 1, 1:2) - mtn_pos(i, 1:3, 1:2) = mtn_pos(i + 1, 1:3, 1:2) - mtn_posPrev(i, 1:3, 1:2) = mtn_posPrev(i + 1, 1:3, 1:2) - mtn_vel(i, 1:3, 1:2) = mtn_vel(i + 1, 1:3, 1:2) - mtn_s(i, 1:3, 1:2) = mtn_s(i + 1, 1:3, 1:2) - intfc_draddt(i, 1:lag_num_ts) = intfc_draddt(i + 1, 1:lag_num_ts) - intfc_dveldt(i, 1:lag_num_ts) = intfc_dveldt(i + 1, 1:lag_num_ts) - gas_dpdt(i, 1:lag_num_ts) = gas_dpdt(i + 1, 1:lag_num_ts) - gas_dmvdt(i, 1:lag_num_ts) = gas_dmvdt(i + 1, 1:lag_num_ts) + gas_p(i,1:2) = gas_p(i + 1,1:2) + gas_mv(i,1:2) = gas_mv(i + 1,1:2) + intfc_rad(i,1:2) = intfc_rad(i + 1,1:2) + intfc_vel(i,1:2) = intfc_vel(i + 1,1:2) + mtn_pos(i,1:3,1:2) = mtn_pos(i + 1,1:3,1:2) + mtn_posPrev(i,1:3,1:2) = mtn_posPrev(i + 1,1:3,1:2) + mtn_vel(i,1:3,1:2) = mtn_vel(i + 1,1:3,1:2) + mtn_s(i,1:3,1:2) = mtn_s(i + 1,1:3,1:2) + intfc_draddt(i,1:lag_num_ts) = intfc_draddt(i + 1,1:lag_num_ts) + intfc_dveldt(i,1:lag_num_ts) = intfc_dveldt(i + 1,1:lag_num_ts) + gas_dpdt(i,1:lag_num_ts) = gas_dpdt(i + 1,1:lag_num_ts) + gas_dmvdt(i,1:lag_num_ts) = gas_dmvdt(i + 1,1:lag_num_ts) end do nBubs = nBubs - 1 diff --git a/src/simulation/m_bubbles_EL_kernels.fpp b/src/simulation/m_bubbles_EL_kernels.fpp index 24eed4516d..f1f80980b0 100644 --- a/src/simulation/m_bubbles_EL_kernels.fpp +++ b/src/simulation/m_bubbles_EL_kernels.fpp @@ -8,6 +8,7 @@ module m_bubbles_EL_kernels use m_mpi_proxy + implicit none contains @@ -15,10 +16,10 @@ contains !> Smear the Lagrangian bubble effects onto the Eulerian grid using the selected kernel subroutine s_smoothfunction(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) - integer, intent(in) :: nBubs - real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s, lbk_pos - real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel - type(scalar_field), dimension(:), intent(inout) :: updatedvar + integer, intent(in) :: nBubs + real(wp), dimension(1:lag_params%nBubs_glb,1:3,1:2), intent(in) :: lbk_s, lbk_pos + real(wp), dimension(1:lag_params%nBubs_glb,1:2), intent(in) :: lbk_rad, lbk_vel + type(scalar_field), dimension(:), intent(inout) :: updatedvar smoothfunc:select case(lag_params%smooth_type) case (1) @@ -32,21 +33,21 @@ contains !> Apply the delta kernel function to map bubble effects onto the containing cell subroutine s_deltafunc(nBubs, lbk_rad, lbk_vel, lbk_s, updatedvar) - integer, intent(in) :: nBubs - real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s - real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel - type(scalar_field), dimension(:), intent(inout) :: updatedvar - integer, dimension(3) :: cell - real(wp) :: strength_vel, strength_vol - real(wp) :: addFun1, addFun2, addFun3 - real(wp) :: volpart, Vol - real(wp), dimension(3) :: s_coord - integer :: l + integer, intent(in) :: nBubs + real(wp), dimension(1:lag_params%nBubs_glb,1:3,1:2), intent(in) :: lbk_s + real(wp), dimension(1:lag_params%nBubs_glb,1:2), intent(in) :: lbk_rad, lbk_vel + type(scalar_field), dimension(:), intent(inout) :: updatedvar + integer, dimension(3) :: cell + real(wp) :: strength_vel, strength_vol + real(wp) :: addFun1, addFun2, addFun3 + real(wp) :: volpart, Vol + real(wp), dimension(3) :: s_coord + integer :: l $:GPU_PARALLEL_LOOP(private='[l, s_coord, cell]') do l = 1, nBubs volpart = 4._wp/3._wp*pi*lbk_rad(l, 2)**3._wp - s_coord(1:3) = lbk_s(l, 1:3, 2) + s_coord(1:3) = lbk_s(l,1:3,2) call s_get_cell(s_coord, cell) strength_vol = volpart @@ -83,22 +84,22 @@ contains !> Apply the Gaussian kernel function to smear bubble effects onto surrounding cells subroutine s_gaussian(nBubs, lbk_rad, lbk_vel, lbk_s, lbk_pos, updatedvar) - integer, intent(in) :: nBubs - real(wp), dimension(1:lag_params%nBubs_glb, 1:3, 1:2), intent(in) :: lbk_s, lbk_pos - real(wp), dimension(1:lag_params%nBubs_glb, 1:2), intent(in) :: lbk_rad, lbk_vel - type(scalar_field), dimension(:), intent(inout) :: updatedvar - real(wp), dimension(3) :: center - integer, dimension(3) :: cell - real(wp) :: stddsv - real(wp) :: strength_vel, strength_vol - real(wp), dimension(3) :: nodecoord - real(wp) :: addFun1, addFun2, addFun3 - real(wp) :: func, func2, volpart - integer, dimension(3) :: cellaux - real(wp), dimension(3) :: s_coord - integer :: l, i, j, k - logical :: celloutside - integer :: smearGrid, smearGridz + integer, intent(in) :: nBubs + real(wp), dimension(1:lag_params%nBubs_glb,1:3,1:2), intent(in) :: lbk_s, lbk_pos + real(wp), dimension(1:lag_params%nBubs_glb,1:2), intent(in) :: lbk_rad, lbk_vel + type(scalar_field), dimension(:), intent(inout) :: updatedvar + real(wp), dimension(3) :: center + integer, dimension(3) :: cell + real(wp) :: stddsv + real(wp) :: strength_vel, strength_vol + real(wp), dimension(3) :: nodecoord + real(wp) :: addFun1, addFun2, addFun3 + real(wp) :: func, func2, volpart + integer, dimension(3) :: cellaux + real(wp), dimension(3) :: s_coord + integer :: l, i, j, k + logical :: celloutside + integer :: smearGrid, smearGridz smearGrid = mapCells - (-mapCells) + 1 ! Include the cell that contains the bubble (3+1+3) smearGridz = smearGrid @@ -109,8 +110,8 @@ contains nodecoord(1:3) = 0 center(1:3) = 0._wp volpart = 4._wp/3._wp*pi*lbk_rad(l, 2)**3._wp - s_coord(1:3) = lbk_s(l, 1:3, 2) - center(1:2) = lbk_pos(l, 1:2, 2) + s_coord(1:3) = lbk_s(l,1:3,2) + center(1:2) = lbk_pos(l,1:2,2) if (p > 0) center(3) = lbk_pos(l, 3, 2) call s_get_cell(s_coord, cell) call s_compute_stddsv(cell, volpart, stddsv) diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index 1614b340b0..0e36c48fbf 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -19,6 +19,7 @@ module m_cbc #:if USING_AMD use m_chemistry, only: molecular_weights_nonparameter #:endif + implicit none private; public :: s_initialize_cbc_module, s_cbc, s_finalize_cbc_module @@ -377,13 +378,13 @@ contains #:for CBC_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (cbc_dir_in == ${CBC_DIR}$ .and. recon_type == WENO_TYPE) then if (weno_order == 1) then - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp + fd_coef_${XYZ}$ (:,cbc_loc_in) = 0._wp fd_coef_${XYZ}$ (0, cbc_loc_in) = -2._wp/(ds(0) + ds(1)) fd_coef_${XYZ}$ (1, cbc_loc_in) = -fd_coef_${XYZ}$ (0, cbc_loc_in) ! Computing CBC2 Coefficients else if (weno_order == 3) then - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp + fd_coef_${XYZ}$ (:,cbc_loc_in) = 0._wp fd_coef_${XYZ}$ (0, cbc_loc_in) = -6._wp/(3._wp*ds(0) + 2._wp*ds(1) - ds(2)) fd_coef_${XYZ}$ (1, cbc_loc_in) = -4._wp*fd_coef_${XYZ}$ (0, cbc_loc_in)/3._wp fd_coef_${XYZ}$ (2, cbc_loc_in) = fd_coef_${XYZ}$ (0, cbc_loc_in)/3._wp @@ -392,7 +393,7 @@ contains ! Computing CBC4 Coefficients else - fd_coef_${XYZ}$ (:, cbc_loc_in) = 0._wp + fd_coef_${XYZ}$ (:,cbc_loc_in) = 0._wp fd_coef_${XYZ}$ (0, & & cbc_loc_in) = -50._wp/(25._wp*ds(0) + 2._wp*ds(1) - 1.e1_wp*ds(2) + 1.e1_wp*ds(3) & & - 3._wp*ds(4)) diff --git a/src/simulation/m_checker.fpp b/src/simulation/m_checker.fpp index d8c194f9b2..478f778c84 100644 --- a/src/simulation/m_checker.fpp +++ b/src/simulation/m_checker.fpp @@ -12,6 +12,7 @@ module m_checker use m_mpi_proxy use m_helper use m_helper_basic + implicit none private; public :: s_check_inputs diff --git a/src/simulation/m_compute_cbc.fpp b/src/simulation/m_compute_cbc.fpp index a4b51ecc1d..cbeac697af 100644 --- a/src/simulation/m_compute_cbc.fpp +++ b/src/simulation/m_compute_cbc.fpp @@ -8,6 +8,7 @@ module m_compute_cbc use m_global_parameters + implicit none private; public :: s_compute_slip_wall_L, s_compute_nonreflecting_subsonic_buffer_L, & diff --git a/src/simulation/m_compute_levelset.fpp b/src/simulation/m_compute_levelset.fpp index 842313b634..da1dcd9109 100644 --- a/src/simulation/m_compute_levelset.fpp +++ b/src/simulation/m_compute_levelset.fpp @@ -13,6 +13,7 @@ module m_compute_levelset use m_global_parameters use m_mpi_proxy use m_helper_basic + implicit none private; public :: s_apply_levelset @@ -113,7 +114,7 @@ contains real(wp), dimension(3) :: dist_vec real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame real(wp), dimension(1:2) :: center - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + real(wp), dimension(1:3,1:3) :: rotation, inverse_rotation integer :: i, j, k, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -192,7 +193,7 @@ contains real(wp) :: lz, z_max, z_min real(wp), dimension(3) :: dist_vec real(wp), dimension(1:3) :: xyz_local, center, offset, normal !< x, y, z coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + real(wp), dimension(1:3,1:3) :: rotation, inverse_rotation real(wp) :: length_z integer :: i, j, k, l, ib_patch_id !< Loop index variables ib_patch_id = gp%ib_patch_id @@ -291,7 +292,7 @@ contains real(wp) :: length_x, length_y real(wp), dimension(1:3) :: xy_local, dist_vec !< x and y coordinates in local IB frame real(wp), dimension(2) :: center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + real(wp), dimension(1:3,1:3) :: rotation, inverse_rotation integer :: i, j, k !< Loop index variables integer :: idx !< Shortest path direction indicator integer :: ib_patch_id !< patch ID @@ -353,12 +354,12 @@ contains $:GPU_ROUTINE(parallelism='[seq]') type(ghost_point), intent(inout) :: gp - real(wp) :: ellipse_coeffs(2) ! a and b in the ellipse equation - real(wp) :: quadratic_coeffs(3) ! A, B, C in the quadratic equation to compute levelset + real(wp) :: ellipse_coeffs(2) !< a and b in the ellipse equation + real(wp) :: quadratic_coeffs(3) !< A, B, C in the quadratic equation to compute levelset real(wp) :: length_x, length_y real(wp), dimension(1:3) :: xy_local, normal_vector !< x and y coordinates in local IB frame real(wp), dimension(2) :: center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + real(wp), dimension(1:3,1:3) :: rotation, inverse_rotation integer :: i, j, k !< Loop index variables integer :: idx !< Shortest path direction indicator integer :: ib_patch_id !< patch ID @@ -409,7 +410,7 @@ contains real(wp), dimension(3) :: center real(wp) :: length_x, length_y, length_z real(wp), dimension(1:3) :: xyz_local, dist_vec !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + real(wp), dimension(1:3,1:3) :: rotation, inverse_rotation integer :: i, j, k !< Loop index variables integer :: ib_patch_id !< patch ID ib_patch_id = gp%ib_patch_id @@ -533,7 +534,7 @@ contains integer :: i, j, k !< Loop index variables integer :: ib_patch_id !< patch ID real(wp), dimension(1:3) :: xyz_local, center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: rotation, inverse_rotation + real(wp), dimension(1:3,1:3) :: rotation, inverse_rotation ib_patch_id = gp%ib_patch_id i = gp%loc(1) @@ -604,7 +605,7 @@ contains real(wp), dimension(1:3) :: center, xyz_local real(wp) :: normals(1:3) !< Boundary normal buffer real(wp) :: distance - real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation, rotation patch_id = gp%ib_patch_id i = gp%loc(1) diff --git a/src/simulation/m_data_output.fpp b/src/simulation/m_data_output.fpp index ad27a515e5..086a218289 100644 --- a/src/simulation/m_data_output.fpp +++ b/src/simulation/m_data_output.fpp @@ -59,12 +59,12 @@ contains !> Write data files. Dispatch subroutine that replaces procedure pointer. impure subroutine s_write_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - type(scalar_field), intent(inout) :: q_T_sf - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - integer, intent(in) :: t_step - type(scalar_field), intent(inout), optional :: beta - type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + integer, intent(in) :: t_step + type(scalar_field), intent(inout), optional :: beta + type(integer_field), dimension(1:num_dims,-1:1), intent(in) :: bc_type if (.not. parallel_io) then call s_write_serial_data_files(q_cons_vf, q_T_sf, q_prim_vf, t_step, bc_type, beta) @@ -300,7 +300,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf integer, intent(in) :: t_step type(scalar_field), intent(inout), optional :: beta - type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type + type(integer_field), dimension(1:num_dims,-1:1), intent(in) :: bc_type character(LEN=path_len + 2*name_len) :: t_step_dir !< Relative path to the current time-step directory character(LEN=path_len + 3*name_len) :: file_path !< Relative path to the grid and conservative variables data files logical :: file_exist !< Logical used to check existence of current time-step directory @@ -340,7 +340,7 @@ contains open (2, FILE=trim(file_path), form='unformatted', STATUS='new') - write (2) q_cons_vf(i)%sf(0:m, 0:n, 0:p); close (2) + write (2) q_cons_vf(i)%sf(0:m,0:n,0:p); close (2) end do ! Lagrangian beta (void fraction) written as q_cons_vf(sys_size+1) to match the parallel I/O path and allow post_process to @@ -350,7 +350,7 @@ contains open (2, FILE=trim(file_path), form='unformatted', STATUS='new') - write (2) beta%sf(0:m, 0:n, 0:p); close (2) + write (2) beta%sf(0:m,0:n,0:p); close (2) end if if (qbmm .and. .not. polytropic) then @@ -360,7 +360,7 @@ contains open (2, FILE=trim(file_path), form='unformatted', STATUS='new') - write (2) pb_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) + write (2) pb_ts(1)%sf(0:m,0:n,0:p,r, i); close (2) end do end do @@ -370,7 +370,7 @@ contains open (2, FILE=trim(file_path), form='unformatted', STATUS='new') - write (2) mv_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) + write (2) mv_ts(1)%sf(0:m,0:n,0:p,r, i); close (2) end do end do end if @@ -651,10 +651,10 @@ contains !> Write grid and conservative variable data files in parallel via MPI I/O impure subroutine s_write_parallel_data_files(q_cons_vf, t_step, bc_type, beta) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - integer, intent(in) :: t_step - type(scalar_field), intent(inout), optional :: beta - type(integer_field), dimension(1:num_dims, -1:1), intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + integer, intent(in) :: t_step + type(scalar_field), intent(inout), optional :: beta + type(integer_field), dimension(1:num_dims,-1:1), intent(in) :: bc_type #ifdef MFC_MPI integer :: ifile, ierr, data_size @@ -672,7 +672,7 @@ contains ! Down sampling variables integer :: m_ds, n_ds, p_ds integer :: m_glb_ds, n_glb_ds, p_glb_ds - integer :: m_glb_save, n_glb_save, p_glb_save ! Global save size + integer :: m_glb_save, n_glb_save, p_glb_save !< Global save size if (down_sample) then call s_downsample_data(q_cons_vf, q_cons_temp_ds, m_ds, n_ds, p_ds, m_glb_ds, n_glb_ds, p_glb_ds) @@ -858,7 +858,7 @@ contains open (2, FILE=trim(file_path), form='unformatted', STATUS='new') $:GPU_UPDATE(host='[ib_markers%sf]') - write (2) ib_markers%sf(0:m, 0:n, 0:p); close (2) + write (2) ib_markers%sf(0:m,0:n,0:p); close (2) end subroutine s_write_serial_ib_data @@ -962,7 +962,7 @@ contains integer, intent(in) :: t_step type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf - real(wp), dimension(0:m, 0:n, 0:p), intent(in) :: accel_mag + real(wp), dimension(0:m,0:n,0:p), intent(in) :: accel_mag real(wp), dimension(-1:m) :: distx real(wp), dimension(-1:n) :: disty real(wp), dimension(-1:p) :: distz @@ -1573,7 +1573,7 @@ contains allocate (q_cons_temp_ds(1:sys_size)) do i = 1, sys_size - allocate (q_cons_temp_ds(i)%sf(-1:m_ds + 1, -1:n_ds + 1, -1:p_ds + 1)) + allocate (q_cons_temp_ds(i)%sf(-1:m_ds + 1,-1:n_ds + 1,-1:p_ds + 1)) end do end if diff --git a/src/simulation/m_derived_variables.fpp b/src/simulation/m_derived_variables.fpp index 80149b2303..d0be1a8426 100644 --- a/src/simulation/m_derived_variables.fpp +++ b/src/simulation/m_derived_variables.fpp @@ -150,7 +150,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf1 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf2 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf3 - real(wp), dimension(0:m, 0:n, 0:p), intent(out) :: q_sf + real(wp), dimension(0:m,0:n,0:p), intent(out) :: q_sf integer :: j, k, l, r !< Generic loop iterators ! Computing the acceleration component in the x-coordinate direction @@ -340,7 +340,7 @@ contains impure subroutine s_derive_center_of_mass(q_vf, c_m) type(scalar_field), dimension(sys_size), intent(in) :: q_vf - real(wp), dimension(1:num_fluids, 1:5), intent(inout) :: c_m + real(wp), dimension(1:num_fluids,1:5), intent(inout) :: c_m integer :: i, j, k, l !< Generic loop iterators real(wp) :: tmp, tmp_out !< Temporary variable to store quantity for mpi_allreduce real(wp) :: dV !< Discrete cell volume diff --git a/src/simulation/m_fftw.fpp b/src/simulation/m_fftw.fpp index 320878159f..38005f76ca 100644 --- a/src/simulation/m_fftw.fpp +++ b/src/simulation/m_fftw.fpp @@ -258,12 +258,12 @@ contains do j = 0, m do k = 1, sys_size data_fltr_cmplx(:) = (0_dp, 0_dp) - data_real(1:p + 1) = q_cons_vf(k)%sf(j, 0, 0:p) + data_real(1:p + 1) = q_cons_vf(k)%sf(j, 0,0:p) call fftw_execute_dft_r2c(fwd_plan, data_real, data_cmplx) data_fltr_cmplx(1:Nfq) = data_cmplx(1:Nfq) call fftw_execute_dft_c2r(bwd_plan, data_fltr_cmplx, data_real) data_real(:) = data_real(:)/real(real_size, dp) - q_cons_vf(k)%sf(j, 0, 0:p) = data_real(1:p + 1) + q_cons_vf(k)%sf(j, 0,0:p) = data_real(1:p + 1) end do end do @@ -273,12 +273,12 @@ contains do j = 0, m do k = 1, sys_size data_fltr_cmplx(:) = (0_dp, 0_dp) - data_real(1:p + 1) = q_cons_vf(k)%sf(j, i, 0:p) + data_real(1:p + 1) = q_cons_vf(k)%sf(j, i,0:p) call fftw_execute_dft_r2c(fwd_plan, data_real, data_cmplx) data_fltr_cmplx(1:Nfq) = data_cmplx(1:Nfq) call fftw_execute_dft_c2r(bwd_plan, data_fltr_cmplx, data_real) data_real(:) = data_real(:)/real(real_size, dp) - q_cons_vf(k)%sf(j, i, 0:p) = data_real(1:p + 1) + q_cons_vf(k)%sf(j, i,0:p) = data_real(1:p + 1) end do end do end do diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index b8c96aff23..079d36ebc2 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -141,17 +141,17 @@ module m_global_parameters !> @name Variables for our of core IGR computation on NVIDIA !> @{ - logical :: nv_uvm_out_of_core ! Enable out-of-core storage of q_cons_ts(2) in timestepping (default FALSE) - integer :: nv_uvm_igr_temps_on_gpu ! 0 => jac, jac_rhs, and jac_old on CPU + logical :: nv_uvm_out_of_core !< Enable out-of-core storage of q_cons_ts(2) in timestepping (default FALSE) + integer :: nv_uvm_igr_temps_on_gpu !< 0 => jac, jac_rhs, and jac_old on CPU ! 1 => jac on GPU, jac_rhs and jac_old on CPU 2 => jac and jac_rhs on GPU, jac_old on CPU 3 => jac, jac_rhs, and jac_old on GPU ! (default) - logical :: nv_uvm_pref_gpu ! Enable explicit gpu memory hints (default FALSE) + logical :: nv_uvm_pref_gpu !< Enable explicit gpu memory hints (default FALSE) !> @} real(wp) :: weno_eps !< Binding for the WENO nonlinear weights real(wp) :: teno_CT !< Smoothness threshold for TENO logical :: mp_weno !< Monotonicity preserving (MP) WENO - logical :: weno_avg ! Average left/right cell-boundary states + logical :: weno_avg !< Average left/right cell-boundary states logical :: weno_Re_flux !< WENO reconstruct velocity gradients for viscous stress tensor integer :: riemann_solver !< Riemann solver algorithm integer :: low_Mach !< Low Mach number fix to HLLC Riemann solver @@ -311,34 +311,24 @@ module m_global_parameters $:GPU_DECLARE(create='[dir_idx, dir_flg, dir_idx_tau]') - !> The number of cells that are necessary to be able to store enough boundary conditions data to march the solution in the - !! physical computational domain to the next time-step. - integer :: buff_size + integer :: buff_size !< Number of ghost cells for boundary condition storage $:GPU_DECLARE(create='[buff_size]') - integer :: shear_num !< Number of shear stress components - integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress - integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions - !> Indices of shear stress components to reflect for boundary conditions. Size: (1:3, 1:shear_BC_flip_num) for (x/y/z, - !! [indices]) - integer, dimension(3, 2) :: shear_BC_flip_indices + integer :: shear_num !< Number of shear stress components + integer, dimension(3) :: shear_indices !< Indices of the stress components that represent shear stress + integer :: shear_BC_flip_num !< Number of shear stress components to reflect for boundary conditions + integer, dimension(3, 2) :: shear_BC_flip_indices !< Shear stress BC reflection indices (1:3, 1:shear_BC_flip_num) $:GPU_DECLARE(create='[shear_num, shear_indices, shear_BC_flip_num, shear_BC_flip_indices]') ! END: Simulation Algorithm Parameters ! Fluids Physical Parameters - !> Database of the physical parameters of each of the fluids that is present in the flow. These include the stiffened gas - !! equation of state parameters, and the Reynolds numbers. - type(physical_parameters), dimension(num_fluids_max) :: fluid_pp + type(physical_parameters), dimension(num_fluids_max) :: fluid_pp !< Stiffened gas EOS parameters and Reynolds numbers per fluid ! Subgrid Bubble Parameters type(subgrid_bubble_physical_parameters) :: bub_pp - !> The order of the finite-difference (fd) approximations of the first-order derivatives that need to be evaluated when the CoM - !! or flow probe data files are to be written at each time step - integer :: fd_order - !> The finite-difference number is given by MAX(1, fd_order/2). Essentially, it is a measure of the half-size of the - !! finite-difference stencil for the selected order of accuracy. - integer :: fd_number + integer :: fd_order !< Finite-difference order for CoM and flow probe derivatives + integer :: fd_number !< Finite-difference half-stencil size: MAX(1, fd_order/2) $:GPU_DECLARE(create='[fd_order, fd_number]') logical :: probe_wrt @@ -489,9 +479,7 @@ module m_global_parameters $:GPU_DECLARE(create='[Bx0]') logical :: fft_wrt - !> AMDFlang workaround: keep a dummy logical to avoid a compiler case-optimization bug when a parameter+GPU-kernel conditional - !! is false - logical :: dummy + logical :: dummy !< AMDFlang workaround for case-optimization + GPU-kernel bug !> @name Continuum damage model parameters !> @{! real(wp) :: tau_star !< Stress threshold for continuum damage modeling @@ -1091,15 +1079,15 @@ contains shear_num = 1 shear_indices(1) = stress_idx%beg - 1 + 2 shear_BC_flip_num = 1 - shear_BC_flip_indices(1:2, 1) = shear_indices(1) + shear_BC_flip_indices(1:2,1) = shear_indices(1) ! Both x-dir and y-dir: flip tau_xy only else if (num_dims == 3) then shear_num = 3 shear_indices(1:3) = stress_idx%beg - 1 + (/2, 4, 5/) shear_BC_flip_num = 2 - shear_BC_flip_indices(1, 1:2) = shear_indices((/1, 2/)) - shear_BC_flip_indices(2, 1:2) = shear_indices((/1, 3/)) - shear_BC_flip_indices(3, 1:2) = shear_indices((/2, 3/)) + shear_BC_flip_indices(1,1:2) = shear_indices((/1, 2/)) + shear_BC_flip_indices(2,1:2) = shear_indices((/1, 3/)) + shear_BC_flip_indices(3,1:2) = shear_indices((/2, 3/)) ! x-dir: flip tau_xy and tau_xz y-dir: flip tau_xy and tau_yz z-dir: flip tau_xz and tau_yz end if $:GPU_UPDATE(device='[shear_num, shear_indices, shear_BC_flip_num, shear_BC_flip_indices]') @@ -1153,18 +1141,18 @@ contains if (.not. down_sample) then do i = 1, sys_size - allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) + allocate (MPI_IO_DATA%var(i)%sf(0:m,0:n,0:p)) MPI_IO_DATA%var(i)%sf => null() end do end if if (bubbles_euler .and. qbmm .and. .not. polytropic) then do i = sys_size + 1, sys_size + 2*nb*nnode - allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) + allocate (MPI_IO_DATA%var(i)%sf(0:m,0:n,0:p)) MPI_IO_DATA%var(i)%sf => null() end do else if (bubbles_lagrange) then do i = 1, sys_size + 1 - allocate (MPI_IO_DATA%var(i)%sf(0:m, 0:n, 0:p)) + allocate (MPI_IO_DATA%var(i)%sf(0:m,0:n,0:p)) MPI_IO_DATA%var(i)%sf => null() end do end if @@ -1178,7 +1166,7 @@ contains wenojs = .not. (mapped_weno .or. wenoz .or. teno) #:endif - if (ib) allocate (MPI_IO_IB_DATA%var%sf(0:m, 0:n, 0:p)) + if (ib) allocate (MPI_IO_IB_DATA%var%sf(0:m,0:n,0:p)) Np = 0 if (elasticity) then diff --git a/src/simulation/m_hypoelastic.fpp b/src/simulation/m_hypoelastic.fpp index f5d504d60d..d38741934e 100644 --- a/src/simulation/m_hypoelastic.fpp +++ b/src/simulation/m_hypoelastic.fpp @@ -351,7 +351,7 @@ contains type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - real(wp) :: tau_p ! principal stress + real(wp) :: tau_p !< principal stress real(wp) :: tau_xx, tau_xy, tau_yy, tau_zz, tau_yz, tau_xz real(wp) :: I1, I2, I3, argument, phi, sqrt_term_1, sqrt_term_2, temp integer :: q, l, k diff --git a/src/simulation/m_ib_patches.fpp b/src/simulation/m_ib_patches.fpp index dbbbfa5327..a7d8e45eee 100644 --- a/src/simulation/m_ib_patches.fpp +++ b/src/simulation/m_ib_patches.fpp @@ -47,7 +47,7 @@ module m_ib_patches ! patch boundaries in the x-, y- and z-coordinate directions. They are used as a means to concisely perform the actions ! necessary to lay out a particular patch on the grid. - character(len=5) :: istr ! string to store int to string result for error checking + character(len=5) :: istr !< string to store int to string result for error checking contains @@ -55,8 +55,8 @@ contains impure subroutine s_apply_ib_patches(ib_markers) type(integer_field), intent(inout) :: ib_markers - integer :: i, xp, yp, zp ! iterators - integer :: xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper ! periodic bounds + integer :: i, xp, yp, zp !< iterators + integer :: xp_lower, xp_upper, yp_lower, yp_upper, zp_lower, zp_upper !< periodic bounds ! 3D Patch Geometries @@ -167,7 +167,7 @@ contains integer :: encoded_patch_id real(wp), dimension(1:3) :: xy_local, offset !< x and y coordinates in local IB frame real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) @@ -320,7 +320,7 @@ contains integer :: Np1, Np2 integer :: encoded_patch_id real(wp), dimension(1:3) :: xyz_local, center, offset !< x, y, z coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) center(2) = patch_ib(patch_id)%y_centroid + real(yp, wp)*(y_domain%end - y_domain%beg) @@ -476,7 +476,7 @@ contains real(wp) :: corner_distance !< Equation of state parameters real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame real(wp), dimension(1:2) :: length, center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation ! Transferring the rectangle's centroid and length information @@ -586,7 +586,7 @@ contains integer :: i, j, k, ir, il, jr, jl, kr, kl !< Generic loop iterators integer :: encoded_patch_id real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation real(wp) :: corner_distance ! Transferring the cuboid's centroid and length information @@ -655,7 +655,7 @@ contains integer :: encoded_patch_id real(wp) :: radius real(wp), dimension(1:3) :: xyz_local, center, length !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation real(wp) :: corner_distance ! Transferring the cylindrical patch's centroid, length, radius, @@ -727,7 +727,7 @@ contains real(wp), dimension(1:3) :: xy_local !< x and y coordinates in local IB frame real(wp), dimension(1:2) :: ellipse_coeffs !< a and b in the ellipse coefficients real(wp), dimension(1:2) :: center !< x and y coordinates in local IB frame - real(wp), dimension(1:3, 1:3) :: inverse_rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation ! Transferring the ellipse's centroid and length information @@ -783,7 +783,7 @@ contains real(wp) :: eta, threshold real(wp), dimension(1:3) :: point, local_point, offset real(wp), dimension(1:3) :: center, xy_local - real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation, rotation center = 0._wp center(1) = patch_ib(patch_id)%x_centroid + real(xp, wp)*(x_domain%end - x_domain%beg) @@ -856,7 +856,7 @@ contains real(wp) :: eta, threshold, corner_distance real(wp), dimension(1:3) :: point, local_point, offset real(wp), dimension(1:3) :: center, xyz_local - real(wp), dimension(1:3, 1:3) :: inverse_rotation, rotation + real(wp), dimension(1:3,1:3) :: inverse_rotation, rotation integer :: cx, cy, cz real(wp) :: lx(2), ly(2), lz(2) real(wp), dimension(1:3) :: bbox_min, bbox_max, local_corner, world_corner diff --git a/src/simulation/m_ibm.fpp b/src/simulation/m_ibm.fpp index 6c5799a8e0..785bf2dec3 100644 --- a/src/simulation/m_ibm.fpp +++ b/src/simulation/m_ibm.fpp @@ -127,7 +127,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Primitive Variables type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive Variables - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), optional, intent(inout) :: pb_in, mv_in + real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), optional, intent(inout) :: pb_in, mv_in integer :: i, j, k, l, q, r !< Iterator variables integer :: patch_id !< Patch ID of ghost point real(wp) :: rho, gamma, pi_inf, dyn_pres !< Mixture variables @@ -684,13 +684,13 @@ contains if (ib_markers%sf(i + 1, j + 1, k) /= 0) alpha(2, 2, 1) = 0._wp if (p == 0) then - eta(:,:, 1) = 1._wp/dist(:,:, 1)**2 - buf = sum(alpha(:,:, 1)*eta(:,:, 1)) + eta(:,:,1) = 1._wp/dist(:,:,1)**2 + buf = sum(alpha(:,:,1)*eta(:,:,1)) if (buf > 0._wp) then - interp_coeffs(:,:, 1) = alpha(:,:, 1)*eta(:,:, 1)/buf + interp_coeffs(:,:,1) = alpha(:,:,1)*eta(:,:,1)/buf else - buf = sum(eta(:,:, 1)) - interp_coeffs(:,:, 1) = eta(:,:, 1)/buf + buf = sum(eta(:,:,1)) + interp_coeffs(:,:,1) = eta(:,:,1)/buf end if else if (ib_markers%sf(i, j, k + 1) /= 0) alpha(1, 1, 2) = 0._wp @@ -721,7 +721,7 @@ contains & nmom_IP, pb_in, mv_in, presb_IP, massv_IP) $:GPU_ROUTINE(parallelism='[seq]') type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf !< Primitive Variables - real(stp), optional, dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(in) :: pb_in, mv_in + real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(in) :: pb_in, mv_in type(ghost_point), intent(in) :: gp real(wp), intent(inout) :: pres_IP real(wp), dimension(3), intent(inout) :: vel_IP @@ -886,7 +886,7 @@ contains type(physical_parameters), dimension(1:num_fluids), intent(in) :: fluid_pp integer :: gp_id, i, j, k, l, q, ib_idx, fluid_idx real(wp), dimension(num_ibs, 3) :: forces, torques - real(wp), dimension(1:3, 1:3) :: viscous_stress_div, viscous_stress_div_1, & + real(wp), dimension(1:3,1:3) :: viscous_stress_div, viscous_stress_div_1, & & viscous_stress_div_2 ! viscous stress tensor with temp vectors to hold divergence calculations real(wp), dimension(1:3) :: local_force_contribution, radial_vector, local_torque_contribution, vel real(wp) :: cell_volume, dx, dy, dz, dynamic_viscosity @@ -964,14 +964,14 @@ contains ! get the linear force components first call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i - 1, j, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i + 1, j, k) - viscous_stress_div(1, 1:3) = (viscous_stress_div_2(1, 1:3) - viscous_stress_div_1(1, & + viscous_stress_div(1,1:3) = (viscous_stress_div_2(1,1:3) - viscous_stress_div_1(1, & & 1:3))/(2._wp*dx) ! get x derivative of the first-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(1, & & 1:3) ! add the x components of the divergence to the force call s_compute_viscous_stress_tensor(viscous_stress_div_1, q_prim_vf, dynamic_viscosity, i, j - 1, k) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j + 1, k) - viscous_stress_div(2, 1:3) = (viscous_stress_div_2(2, 1:3) - viscous_stress_div_1(2, & + viscous_stress_div(2,1:3) = (viscous_stress_div_2(2,1:3) - viscous_stress_div_1(2, & & 1:3))/(2._wp*dy) ! get y derivative of the second-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(2, & & 1:3) ! add the y components of the divergence to the force @@ -981,7 +981,7 @@ contains & k - 1) call s_compute_viscous_stress_tensor(viscous_stress_div_2, q_prim_vf, dynamic_viscosity, i, j, & & k + 1) - viscous_stress_div(3, 1:3) = (viscous_stress_div_2(3, 1:3) - viscous_stress_div_1(3, & + viscous_stress_div(3,1:3) = (viscous_stress_div_2(3,1:3) - viscous_stress_div_1(3, & & 1:3))/(2._wp*dz) ! get z derivative of the third-row of viscous stress tensor local_force_contribution(1:3) = local_force_contribution(1:3) + viscous_stress_div(3, & & 1:3) ! add the z components of the divergence to the force diff --git a/src/simulation/m_igr.fpp b/src/simulation/m_igr.fpp index 7ce218829c..7d0f18cb26 100644 --- a/src/simulation/m_igr.fpp +++ b/src/simulation/m_igr.fpp @@ -115,17 +115,17 @@ contains @:ALLOCATE(jac(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(jac) else - allocate (jac_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + allocate (jac_host(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end,idwbuff(3)%beg:idwbuff(3)%end)) - jac(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end) => jac_host(:,:,:) + jac(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end,idwbuff(3)%beg:idwbuff(3)%end) => jac_host(:,:,:) end if if (nv_uvm_temp_on_gpu(2) == 1) then @:ALLOCATE(jac_rhs(-1:m,-1:n,-1:p)) @:PREFER_GPU(jac_rhs) else - allocate (jac_rhs_host(-1:m, -1:n, -1:p)) - jac_rhs(-1:m, -1:n, -1:p) => jac_rhs_host(:,:,:) + allocate (jac_rhs_host(-1:m,-1:n,-1:p)) + jac_rhs(-1:m,-1:n,-1:p) => jac_rhs_host(:,:,:) end if if (igr_iter_solver == 1) then ! Jacobi iteration @@ -133,9 +133,9 @@ contains @:ALLOCATE(jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) @:PREFER_GPU(jac_old) else - allocate (jac_old_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, idwbuff(3)%beg:idwbuff(3)%end)) + allocate (jac_old_host(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end,idwbuff(3)%beg:idwbuff(3)%end)) - jac_old(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & + jac_old(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end, & & idwbuff(3)%beg:idwbuff(3)%end) => jac_old_host(:,:,:) end if end if @@ -212,12 +212,12 @@ contains #ifdef _CRAYFTN ! DIR$ OPTIMIZE (-haggress) #endif - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - integer, intent(in) :: t_step - real(wp) :: rho_rx, rho_ry, rho_rz, rho_lx, rho_ly, rho_lz - real(wp) :: fd_coeff - integer :: num_iters + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + integer, intent(in) :: t_step + real(wp) :: rho_rx, rho_ry, rho_rz, rho_lx, rho_ly, rho_lz + real(wp) :: fd_coeff + integer :: num_iters if (t_step == t_step_start) then num_iters = num_igr_warm_start_iters diff --git a/src/simulation/m_mpi_proxy.fpp b/src/simulation/m_mpi_proxy.fpp index 0c5780f995..a2b6c84326 100644 --- a/src/simulation/m_mpi_proxy.fpp +++ b/src/simulation/m_mpi_proxy.fpp @@ -22,12 +22,8 @@ module m_mpi_proxy implicit none - !> This variable is utilized to pack and send the buffer of the immersed boundary markers, for a single computational domain - !! boundary at the time, to the relevant neighboring processor. - integer, private, allocatable, dimension(:) :: ib_buff_send - !> q_cons_buff_recv is utilized to receive and unpack the buffer of the immersed boundary markers, for a single computational - !! domain boundary at the time, from the relevant neighboring processor. - integer, private, allocatable, dimension(:) :: ib_buff_recv + integer, private, allocatable, dimension(:) :: ib_buff_send !< IB marker send buffer for halo exchange + integer, private, allocatable, dimension(:) :: ib_buff_recv !< IB marker receive buffer for halo exchange integer :: i_halo_size $:GPU_DECLARE(create='[i_halo_size]') diff --git a/src/simulation/m_muscl.fpp b/src/simulation/m_muscl.fpp index 2dcf0ff050..5c9e844ec6 100644 --- a/src/simulation/m_muscl.fpp +++ b/src/simulation/m_muscl.fpp @@ -95,8 +95,8 @@ contains & is2_muscl_d, is3_muscl_d) - type(scalar_field), dimension(1:), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & + type(scalar_field), dimension(1:), intent(in) :: v_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z integer, intent(in) :: muscl_dir type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d @@ -222,7 +222,7 @@ contains & is1_muscl_d, is2_muscl_d, is3_muscl_d) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & & vL_rs_vf_z, vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z integer, intent(in) :: muscl_dir type(int_bounds_info), intent(in) :: is1_muscl_d, is2_muscl_d, is3_muscl_d diff --git a/src/simulation/m_pressure_relaxation.fpp b/src/simulation/m_pressure_relaxation.fpp index 45fa44287e..7786ce4afe 100644 --- a/src/simulation/m_pressure_relaxation.fpp +++ b/src/simulation/m_pressure_relaxation.fpp @@ -11,6 +11,7 @@ module m_pressure_relaxation use m_derived_types use m_global_parameters + implicit none private; public :: s_pressure_relaxation_procedure, s_initialize_pressure_relaxation_module, & diff --git a/src/simulation/m_qbmm.fpp b/src/simulation/m_qbmm.fpp index 5029b6854c..e32fd92954 100644 --- a/src/simulation/m_qbmm.fpp +++ b/src/simulation/m_qbmm.fpp @@ -403,13 +403,13 @@ contains !> Compute the QBMM right-hand side source terms for bubble moment transport equations subroutine s_compute_qbmm_rhs(idir, q_cons_vf, q_prim_vf, rhs_vf, flux_n_vf, pb, rhs_pb) - integer, intent(in) :: idir - type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf, q_prim_vf - type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - type(scalar_field), dimension(sys_size), intent(in) :: flux_n_vf - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb + integer, intent(in) :: idir + type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf, q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf + type(scalar_field), dimension(sys_size), intent(in) :: flux_n_vf + real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), & & intent(inout) :: rhs_pb ! TODO :: I think that this should be stp as well. integer :: i, j, k, l, q @@ -593,9 +593,9 @@ contains real(wp), intent(in) :: pres, rho, c #:if USING_AMD - real(wp), dimension(32, 0:2, 0:2), intent(out) :: coeffs + real(wp), dimension(32,0:2,0:2), intent(out) :: coeffs #:else - real(wp), dimension(nterms, 0:2, 0:2), intent(out) :: coeffs + real(wp), dimension(nterms,0:2,0:2), intent(out) :: coeffs #:endif integer :: i1, i2 @@ -672,9 +672,9 @@ contains real(wp), intent(in) :: pres, rho, c #:if USING_AMD - real(wp), dimension(32, 0:2, 0:2), intent(out) :: coeffs + real(wp), dimension(32,0:2,0:2), intent(out) :: coeffs #:else - real(wp), dimension(nterms, 0:2, 0:2), intent(out) :: coeffs + real(wp), dimension(nterms,0:2,0:2), intent(out) :: coeffs #:endif integer :: i1, i2 @@ -737,14 +737,14 @@ contains !> Perform moment inversion to recover quadrature weights and abscissas and evaluate bubble source terms subroutine s_mom_inv(q_cons_vf, q_prim_vf, momsp, moms3d, pb, rhs_pb, mv, rhs_mv, ix, iy, iz) - type(scalar_field), dimension(:), intent(inout) :: q_cons_vf, q_prim_vf - type(scalar_field), dimension(:), intent(inout) :: momsp - type(scalar_field), dimension(0:, 0:,:), intent(inout) :: moms3d - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_pb - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: mv - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv - type(int_bounds_info), intent(in) :: ix, iy, iz + type(scalar_field), dimension(:), intent(inout) :: q_cons_vf, q_prim_vf + type(scalar_field), dimension(:), intent(inout) :: momsp + type(scalar_field), dimension(0:,0:,:), intent(inout) :: moms3d + real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: rhs_pb + real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: mv + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: rhs_mv + type(int_bounds_info), intent(in) :: ix, iy, iz #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(6) :: moms, msum @@ -754,9 +754,9 @@ contains real(wp), dimension(nnode, nb) :: wght, abscX, abscY, wght_pb, wght_mv, wght_ht, ht #:endif #:if USING_AMD - real(wp), dimension(32, 0:2, 0:2) :: coeff + real(wp), dimension(32,0:2,0:2) :: coeff #:else - real(wp), dimension(nterms, 0:2, 0:2) :: coeff + real(wp), dimension(nterms,0:2,0:2) :: coeff #:endif real(wp) :: pres, rho, nbub, c, alf, momsum, drdt, drdt2, chi_vw, x_vw, rho_mw, k_mw, grad_T real(wp) :: n_tait, B_tait @@ -794,7 +794,7 @@ contains moms(r) = q_prim_vf(bubmoms(q, r))%sf(id1, id2, id3) end do moms(1) = 1._wp - call s_chyqmom(moms, wght(:, q), abscX(:, q), abscY(:, q)) + call s_chyqmom(moms, wght(:,q), abscX(:,q), abscY(:,q)) if (polytropic) then $:GPU_LOOP(parallelism='[seq]') @@ -837,31 +837,31 @@ contains case (3) if (j == 3) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, & - & q), momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:,q), abscY(:,q), wght_pb(:,q), & + & momrhs(:,i1, i2, j, q)) else momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), & - & momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:,q), abscY(:,q), wght(:,q), & + & momrhs(:,i1, i2, j, q)) end if case (2) if ((j >= 7 .and. j <= 9) .or. (j >= 22 .and. j <= 23) & & .or. (j >= 10 .and. j <= 11) .or. (j == 26)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_pb(:, & - & q), momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:,q), abscY(:,q), wght_pb(:,q), & + & momrhs(:,i1, i2, j, q)) else if ((j >= 27 .and. j <= 29) .and. (.not. polytropic)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_mv(:, & - & q), momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:,q), abscY(:,q), wght_mv(:,q), & + & momrhs(:,i1, i2, j, q)) else if ((j >= 30 .and. j <= 32) .and. (.not. polytropic)) then momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght_ht(:, & - & q), momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:,q), abscY(:,q), wght_ht(:,q), & + & momrhs(:,i1, i2, j, q)) else momsum = momsum + coeff(j, i1, i2)*(R0(q)**momrhs(3, i1, i2, j, & - & q))*f_quad2D(abscX(:, q), abscY(:, q), wght(:, q), & - & momrhs(:, i1, i2, j, q)) + & q))*f_quad2D(abscX(:,q), abscY(:,q), wght(:,q), & + & momrhs(:,i1, i2, j, q)) end if end select end do @@ -936,9 +936,9 @@ contains $:GPU_ROUTINE(function_name='s_coeff_selector',parallelism='[seq]', cray_inline=True) real(wp), intent(in) :: pres, rho, c #:if USING_AMD - real(wp), dimension(32, 0:2, 0:2), intent(out) :: coeff + real(wp), dimension(32,0:2,0:2), intent(out) :: coeff #:else - real(wp), dimension(nterms, 0:2, 0:2), intent(out) :: coeff + real(wp), dimension(nterms,0:2,0:2), intent(out) :: coeff #:endif logical, intent(in) :: polytropic if (polytropic) then @@ -958,11 +958,11 @@ contains real(wp), dimension(nnode), intent(inout) :: wght, abscX, abscY ! Local variables - real(wp), dimension(0:2, 0:2) :: moms - real(wp), dimension(3) :: M1, M3 - real(wp), dimension(2) :: myrho, myrho3, up, up3, Vf - real(wp) :: bu, bv, d20, d11, d_02, c20, c11, c02 - real(wp) :: mu2, vp21, vp22, rho21, rho22 + real(wp), dimension(0:2,0:2) :: moms + real(wp), dimension(3) :: M1, M3 + real(wp), dimension(2) :: myrho, myrho3, up, up3, Vf + real(wp) :: bu, bv, d20, d11, d_02, c20, c11, c02 + real(wp) :: mu2, vp21, vp22, rho21, rho22 ! Assign moments to 2D array for clarity moms(0, 0) = momin(1) diff --git a/src/simulation/m_rhs.fpp b/src/simulation/m_rhs.fpp index 4a03837d3a..1f347a0289 100644 --- a/src/simulation/m_rhs.fpp +++ b/src/simulation/m_rhs.fpp @@ -67,9 +67,7 @@ module m_rhs type(scalar_field), allocatable, dimension(:) :: tau_Re_vf $:GPU_DECLARE(create='[tau_Re_vf]') - !> The gradient magnitude of the volume fractions at cell-interior Gaussian quadrature points. gm_alpha_qp is calculated from - !! individual first-order spatial derivatives located in dq_prim_ds_qp. - type(vector_field) :: gm_alpha_qp + type(vector_field) :: gm_alpha_qp !< Volume fraction gradient magnitudes at cell-interior quadrature points $:GPU_DECLARE(create='[gm_alpha_qp]') !> @name The left and right WENO-reconstructed cell-boundary values of the cell- average gradient magnitude of volume fractions, @@ -538,18 +536,18 @@ contains & time_avg, stage) - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - type(scalar_field), intent(inout) :: q_T_sf - type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: pb_in + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf + real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), & + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), & & intent(inout) & & :: rhs_pb ! TODO :: I think these other two variables need to be stp as well, but it doesn't compile like that right now - real(stp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: mv_in - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:, 1:), intent(inout) :: rhs_mv + real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: mv_in + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: rhs_mv integer, intent(in) :: t_step real(wp), intent(inout) :: time_avg integer, intent(in) :: stage @@ -908,8 +906,8 @@ contains type(vector_field), intent(inout) :: q_cons_vf type(vector_field), intent(inout) :: q_prim_vf type(vector_field), intent(inout) :: flux_src_n_vf - integer :: j, k, l, q ! Loop iterators from original, meaning varies - integer :: k_loop, l_loop, q_loop ! Standardized spatial loop iterators 0:m, 0:n, 0:p + integer :: j, k, l, q !< Loop iterators from original, meaning varies + integer :: k_loop, l_loop, q_loop !< Standardized spatial loop iterators 0:m, 0:n, 0:p integer :: i_fluid_loop real(wp) :: inv_ds, flux_face1, flux_face2 real(wp) :: advected_qty_val, pressure_val, velocity_val @@ -1626,8 +1624,8 @@ contains subroutine s_reconstruct_cell_boundary_values(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_x, vR_y, vR_z + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vL_x, vL_y, vL_z + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir integer :: recon_dir !< Coordinate direction of the reconstruction integer :: i, j, k, l @@ -1651,16 +1649,16 @@ contains if (n > 0) then if (p > 0) then - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & - & :, iv%beg:iv%end), recon_dir, is1, is2, is3) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,iv%beg:iv%end), vL_z(:,:,:, & + & iv%beg:iv%end), vR_x(:,:,:,iv%beg:iv%end), vR_y(:,:,:,iv%beg:iv%end), vR_z(:,:,:, & + & iv%beg:iv%end), recon_dir, is1, is2, is3) else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & - & recon_dir, is1, is2, is3) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,iv%beg:iv%end), vL_z(:,:,:, & + & :), vR_x(:,:,:,iv%beg:iv%end), vR_y(:,:,:,iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, & + & is1, is2, is3) end if else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1, is2, is3) end if end if @@ -1672,8 +1670,8 @@ contains subroutine s_reconstruct_cell_boundary_values_first_order(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_x, vR_y, vR_z + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vL_x, vL_y, vL_z + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir integer :: recon_dir !< Coordinate direction of the WENO reconstruction integer :: i, j, k, l diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 73e796f7a8..72055ef4ab 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -90,8 +90,8 @@ contains & qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & & q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & @@ -142,8 +142,8 @@ contains & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & @@ -205,10 +205,10 @@ contains 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) :: 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 + 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 @@ -819,8 +819,8 @@ contains & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & @@ -884,10 +884,10 @@ contains 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) :: 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 + 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 @@ -1687,8 +1687,8 @@ contains & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & @@ -3300,8 +3300,8 @@ contains & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & & dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf @@ -3634,8 +3634,8 @@ contains & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, & & dqR_prim_dz_vf, norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, & - & qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, & + & qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf @@ -3967,7 +3967,7 @@ contains type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf integer, intent(in) :: norm_dir - integer :: i, j, k, l ! Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators ! Reshaping Inputted Data in x-direction @@ -4190,17 +4190,17 @@ contains case (1) ! x-face (axial face in z_cyl direction) Re_s = Re_avg_rsx_vf(j, k, l, 1) Re_b = Re_avg_rsx_vf(j, k, l, 2) - vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) + vel_src_int = vel_src_rsx_vf(j, k, l,1:num_dims) r_eff = y_cc(k) case (2) ! y-face (radial face in r_cyl direction) Re_s = Re_avg_rsy_vf(k, j, l, 1) Re_b = Re_avg_rsy_vf(k, j, l, 2) - vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) + vel_src_int = vel_src_rsy_vf(k, j, l,1:num_dims) r_eff = y_cb(k) case (3) ! z-face (azimuthal face in theta_cyl direction) Re_s = Re_avg_rsz_vf(l, k, j, 1) Re_b = Re_avg_rsz_vf(l, k, j, 2) - vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) + vel_src_int = vel_src_rsz_vf(l, k, j,1:num_dims) r_eff = y_cc(k) end select diff --git a/src/simulation/m_sim_helpers.fpp b/src/simulation/m_sim_helpers.fpp index 2a4a4133c1..e20ec982fe 100644 --- a/src/simulation/m_sim_helpers.fpp +++ b/src/simulation/m_sim_helpers.fpp @@ -141,13 +141,13 @@ contains subroutine s_compute_stability_from_dt(vel, c, rho, Re_l, j, k, l, icfl_sf, vcfl_sf, Rc_sf) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), intent(in), dimension(num_vels) :: vel - real(wp), intent(in) :: c, rho - real(wp), dimension(0:m, 0:n, 0:p), intent(inout) :: icfl_sf - real(wp), dimension(0:m, 0:n, 0:p), intent(inout), optional :: vcfl_sf, Rc_sf - real(wp), dimension(2), intent(in) :: Re_l - integer, intent(in) :: j, k, l - real(wp) :: fltr_dtheta + real(wp), intent(in), dimension(num_vels) :: vel + real(wp), intent(in) :: c, rho + real(wp), dimension(0:m,0:n,0:p), intent(inout) :: icfl_sf + real(wp), dimension(0:m,0:n,0:p), intent(inout), optional :: vcfl_sf, Rc_sf + real(wp), dimension(2), intent(in) :: Re_l + integer, intent(in) :: j, k, l + real(wp) :: fltr_dtheta ! Inviscid CFL calculation if (p > 0 .or. n > 0) then @@ -191,13 +191,13 @@ contains subroutine s_compute_dt_from_cfl(vel, c, max_dt, rho, Re_l, j, k, l) $:GPU_ROUTINE(parallelism='[seq]') - real(wp), dimension(num_vels), intent(in) :: vel - real(wp), intent(in) :: c, rho - real(wp), dimension(0:m, 0:n, 0:p), intent(inout) :: max_dt - real(wp), dimension(2), intent(in) :: Re_l - integer, intent(in) :: j, k, l - real(wp) :: icfl_dt, vcfl_dt - real(wp) :: fltr_dtheta + real(wp), dimension(num_vels), intent(in) :: vel + real(wp), intent(in) :: c, rho + real(wp), dimension(0:m,0:n,0:p), intent(inout) :: max_dt + real(wp), dimension(2), intent(in) :: Re_l + integer, intent(in) :: j, k, l + real(wp) :: icfl_dt, vcfl_dt + real(wp) :: fltr_dtheta ! Inviscid CFL calculation if (p > 0 .or. n > 0) then diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index c4ff3663ee..c3f38ef500 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -255,7 +255,7 @@ contains inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') - read (2) q_cons_vf(i)%sf(0:m, 0:n, 0:p); close (2) + read (2) q_cons_vf(i)%sf(0:m,0:n,0:p); close (2) else call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if @@ -270,7 +270,7 @@ contains inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') - read (2) pb_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) + read (2) pb_ts(1)%sf(0:m,0:n,0:p,r, i); close (2) else call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if @@ -282,7 +282,7 @@ contains inquire (FILE=trim(file_path), EXIST=file_exist) if (file_exist) then open (2, FILE=trim(file_path), form='unformatted', ACTION='read', STATUS='old') - read (2) mv_ts(1)%sf(0:m, 0:n, 0:p, r, i); close (2) + read (2) mv_ts(1)%sf(0:m,0:n,0:p,r, i); close (2) else call s_mpi_abort(trim(file_path) // ' is missing. Exiting.') end if @@ -315,7 +315,7 @@ contains ! Downsampled data variables integer :: m_ds, n_ds, p_ds integer :: m_glb_ds, n_glb_ds, p_glb_ds - integer :: m_glb_read, n_glb_read, p_glb_read ! data size of read + integer :: m_glb_read, n_glb_read, p_glb_read !< data size of read allocate (x_cb_glb(-1:m_glb)) allocate (y_cb_glb(-1:n_glb)) @@ -884,7 +884,7 @@ contains allocate (q_cons_temp(1:sys_size)) do i = 1, sys_size - allocate (q_cons_temp(i)%sf(-1:m_ds + 1, -1:n_ds + 1, -1:p_ds + 1)) + allocate (q_cons_temp(i)%sf(-1:m_ds + 1,-1:n_ds + 1,-1:p_ds + 1)) end do end if diff --git a/src/simulation/m_surface_tension.fpp b/src/simulation/m_surface_tension.fpp index 11229d9e3f..4ceb4038ba 100644 --- a/src/simulation/m_surface_tension.fpp +++ b/src/simulation/m_surface_tension.fpp @@ -70,9 +70,9 @@ contains !> Compute the capillary source flux from reconstructed color-gradient fields subroutine s_compute_capillary_source_flux(vSrc_rsx_vf, vSrc_rsy_vf, vSrc_rsz_vf, flux_src_vf, id, isx, isy, isz) - real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsx_vf - real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsy_vf - real(wp), dimension(-1:, 0:, 0:, 1:), intent(in) :: vSrc_rsz_vf + real(wp), dimension(-1:,0:,0:,1:), intent(in) :: vSrc_rsx_vf + real(wp), dimension(-1:,0:,0:,1:), intent(in) :: vSrc_rsy_vf + real(wp), dimension(-1:,0:,0:,1:), intent(in) :: vSrc_rsz_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf integer, intent(in) :: id type(int_bounds_info), intent(in) :: isx, isy, isz @@ -218,10 +218,10 @@ contains !> Compute color-function gradients and reconstruct them at cell boundaries impure subroutine s_get_capillary(q_prim_vf, bc_type) - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(integer_field), dimension(1:num_dims, 1:2), intent(in) :: bc_type - type(int_bounds_info) :: isx, isy, isz - integer :: j, k, l, i + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(integer_field), dimension(1:num_dims,1:2), intent(in) :: bc_type + type(int_bounds_info) :: isx, isy, isz + integer :: j, k, l, i isx%beg = -1; isy%beg = 0; isz%beg = 0 @@ -296,8 +296,8 @@ contains subroutine s_reconstruct_cell_boundary_values_capillary(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir) type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(out) :: vL_x, vL_y, vL_z - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(out) :: vR_x, vR_y, vR_z + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,iv%beg:), intent(out) :: vL_x, vL_y, vL_z + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,iv%beg:), intent(out) :: vR_x, vR_y, vR_z integer, intent(in) :: norm_dir integer :: recon_dir !< Coordinate direction of the reconstruction integer :: i, j, k, l diff --git a/src/simulation/m_time_steppers.fpp b/src/simulation/m_time_steppers.fpp index 1ef69f79ef..4a741a4068 100644 --- a/src/simulation/m_time_steppers.fpp +++ b/src/simulation/m_time_steppers.fpp @@ -96,8 +96,8 @@ contains #if defined(__NVCOMPILER_GPU_UNIFIED_MEM) if (num_ts == 2 .and. nv_uvm_out_of_core) then ! host allocation for q_cons_ts(2)%vf(j)%sf for all j - allocate (q_cons_ts_pool_host(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end, 1:sys_size)) + allocate (q_cons_ts_pool_host(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end,1:sys_size)) end if do j = 1, sys_size @@ -108,8 +108,8 @@ contains if (num_ts == 2) then if (nv_uvm_out_of_core) then ! q_cons_ts(2) lives on the host - q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) + q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:,j) else @:ALLOCATE(q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & & idwbuff(3)%beg:idwbuff(3)%end)) @@ -134,11 +134,11 @@ contains & %beg + 1)*sys_size call hipCheck(hipMalloc_(cptr_device, pool_size*2_8)) call c_f_pointer(cptr_device, q_cons_ts_pool_device, shape=pool_dims) - q_cons_ts_pool_device(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:) => q_cons_ts_pool_device + q_cons_ts_pool_device(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:) => q_cons_ts_pool_device call hipCheck(hipMallocManaged_(cptr_host, pool_size*2_8, hipMemAttachGlobal)) call c_f_pointer(cptr_host, q_cons_ts_pool_host, shape=pool_dims) - q_cons_ts_pool_host(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:) => q_cons_ts_pool_host + q_cons_ts_pool_host(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:) => q_cons_ts_pool_host #else ! Doing hipMalloc then mapping should be most performant call hipCheck(hipMalloc(q_cons_ts_pool_device, dims8=pool_dims, lbounds8=pool_starts)) @@ -160,12 +160,12 @@ contains do j = 1, sys_size ! q_cons_ts(1) lives on the device - q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_device(:,:,:, j) + q_cons_ts(1)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_device(:,:,:,j) if (num_ts == 2) then ! q_cons_ts(2) lives on the host - q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end, idwbuff(2)%beg:idwbuff(2)%end, & - & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:, j) + q_cons_ts(2)%vf(j)%sf(idwbuff(1)%beg:idwbuff(1)%end,idwbuff(2)%beg:idwbuff(2)%end, & + & idwbuff(3)%beg:idwbuff(3)%end) => q_cons_ts_pool_host(:,:,:,j) end if end do diff --git a/src/simulation/m_viscous.fpp b/src/simulation/m_viscous.fpp index 0e5052fe21..5f7022714f 100644 --- a/src/simulation/m_viscous.fpp +++ b/src/simulation/m_viscous.fpp @@ -481,8 +481,8 @@ contains & qL_prim, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_n, dqR_prim_dy_n, dqR_prim_dz_n, qR_prim, & & q_prim_qp, dq_prim_dx_qp, dq_prim_dy_qp, dq_prim_dz_qp, 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, qL_prim_rsy_vf, qR_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf, & + & qL_prim_rsy_vf, qR_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsz_vf type(vector_field), dimension(num_dims), intent(inout) :: qL_prim, qR_prim type(vector_field), intent(in) :: q_prim_qp @@ -850,14 +850,13 @@ contains & vR_prim_vf, ix, iy, iz) - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & - & vR_y, vR_z - integer, intent(in) :: norm_dir + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, vR_y, vR_z + integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: recon_dir !< Coordinate direction of the WENO reconstruction - integer :: i, j, k, l + integer :: recon_dir !< Coordinate direction of the WENO reconstruction + integer :: i, j, k, l #:for SCHEME, TYPE in [('weno','WENO_TYPE'), ('muscl','MUSCL_TYPE')] if (recon_type == ${TYPE}$ .or. dummy) then @@ -880,16 +879,16 @@ contains $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous, iv]') if (n > 0) then if (p > 0) then - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & - & :, iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,iv%beg:iv%end), vL_z(:,:,:, & + & iv%beg:iv%end), vR_x(:,:,:,iv%beg:iv%end), vR_y(:,:,:,iv%beg:iv%end), vR_z(:,:,:, & + & iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & - & recon_dir, is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,iv%beg:iv%end), vL_z(:,:,:, & + & :), vR_x(:,:,:,iv%beg:iv%end), vR_y(:,:,:,iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, & + & is1_viscous, is2_viscous, is3_viscous) end if else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & & is3_viscous) end if @@ -947,8 +946,8 @@ contains subroutine s_reconstruct_cell_boundary_values_visc_deriv(v_vf, vL_x, vL_y, vL_z, vR_x, vR_y, vR_z, norm_dir, vL_prim_vf, & & vR_prim_vf, ix, iy, iz) - type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, iv%beg:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & + type(scalar_field), dimension(iv%beg:iv%end), intent(in) :: v_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,iv%beg:), intent(inout) :: vL_x, vL_y, vL_z, vR_x, & & vR_y, vR_z type(scalar_field), dimension(iv%beg:iv%end), intent(inout) :: vL_prim_vf, vR_prim_vf type(int_bounds_info), intent(in) :: ix, iy, iz @@ -976,16 +975,16 @@ contains $:GPU_UPDATE(device='[is1_viscous, is2_viscous, is3_viscous, iv]') if (n > 0) then if (p > 0) then - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :, iv%beg:iv%end), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:, & - & :, iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,iv%beg:iv%end), vL_z(:,:,:, & + & iv%beg:iv%end), vR_x(:,:,:,iv%beg:iv%end), vR_y(:,:,:,iv%beg:iv%end), vR_z(:,:,:, & + & iv%beg:iv%end), recon_dir, is1_viscous, is2_viscous, is3_viscous) else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:, iv%beg:iv%end), vL_z(:,:, & - & :,:), vR_x(:,:,:, iv%beg:iv%end), vR_y(:,:,:, iv%beg:iv%end), vR_z(:,:,:,:), & - & recon_dir, is1_viscous, is2_viscous, is3_viscous) + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,iv%beg:iv%end), vL_z(:,:,:, & + & :), vR_x(:,:,:,iv%beg:iv%end), vR_y(:,:,:,iv%beg:iv%end), vR_z(:,:,:,:), recon_dir, & + & is1_viscous, is2_viscous, is3_viscous) end if else - call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:, iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & + call s_${SCHEME}$ (v_vf(iv%beg:iv%end), vL_x(:,:,:,iv%beg:iv%end), vL_y(:,:,:,:), vL_z(:,:,:,:), vR_x(:,:,:, & & iv%beg:iv%end), vR_y(:,:,:,:), vR_z(:,:,:,:), recon_dir, is1_viscous, is2_viscous, & & is3_viscous) end if @@ -1294,14 +1293,14 @@ contains $:GPU_ROUTINE(parallelism='[seq]') - real(wp), dimension(1:3, 1:3), intent(inout) :: viscous_stress_tensor + real(wp), dimension(1:3,1:3), intent(inout) :: viscous_stress_tensor type(scalar_field), dimension(1:sys_size), intent(in) :: q_prim_vf real(wp), intent(in) :: dynamic_viscosity integer, intent(in) :: i, j, k - real(wp), dimension(1:3, 1:3) :: velocity_gradient_tensor + real(wp), dimension(1:3,1:3) :: velocity_gradient_tensor real(wp), dimension(1:3) :: dx real(wp) :: divergence - integer :: l, q ! iterators + integer :: l, q !< iterators ! zero the viscous stress, collection of velocity derivatives, and spatial finite differences viscous_stress_tensor = 0._wp diff --git a/src/simulation/m_weno.fpp b/src/simulation/m_weno.fpp index 0385ccea23..c2b1cc5ac7 100644 --- a/src/simulation/m_weno.fpp +++ b/src/simulation/m_weno.fpp @@ -180,8 +180,8 @@ contains real(wp), pointer, dimension(:) :: s_cb => null() !< Cell-boundary locations in the s-direction type(int_bounds_info) :: bc_s !< Boundary conditions (BC) in the s-direction integer :: i !< Generic loop iterator - real(wp) :: w(1:8) ! Intermediate var for ideal weights: s_cb across overall stencil - real(wp) :: y(1:4) ! Intermediate var for poly & beta: diff(s_cb) across sub-stencil + real(wp) :: w(1:8) !< Intermediate var for ideal weights: s_cb across overall stencil + real(wp) :: y(1:4) !< Intermediate var for poly & beta: diff(s_cb) across sub-stencil ! Determine cell count, boundary locations, and BCs for selected WENO direction @@ -347,19 +347,19 @@ contains ! BC to avoid any contributions from outside of the physical domain during the WENO reconstruction if (null_weights) then if (bc_s%beg == BC_RIEMANN_EXTRAP) then - d_cbR_${XYZ}$ (1:2, 0) = 0._wp; d_cbR_${XYZ}$ (0, 0) = 1._wp - d_cbL_${XYZ}$ (1:2, 0) = 0._wp; d_cbL_${XYZ}$ (0, 0) = 1._wp - d_cbR_${XYZ}$ (2, 1) = 0._wp; d_cbR_${XYZ}$ (:, 1) = d_cbR_${XYZ}$ (:, 1)/sum(d_cbR_${XYZ}$ (:, 1)) - d_cbL_${XYZ}$ (2, 1) = 0._wp; d_cbL_${XYZ}$ (:, 1) = d_cbL_${XYZ}$ (:, 1)/sum(d_cbL_${XYZ}$ (:, 1)) + d_cbR_${XYZ}$ (1:2,0) = 0._wp; d_cbR_${XYZ}$ (0, 0) = 1._wp + d_cbL_${XYZ}$ (1:2,0) = 0._wp; d_cbL_${XYZ}$ (0, 0) = 1._wp + d_cbR_${XYZ}$ (2, 1) = 0._wp; d_cbR_${XYZ}$ (:,1) = d_cbR_${XYZ}$ (:,1)/sum(d_cbR_${XYZ}$ (:,1)) + d_cbL_${XYZ}$ (2, 1) = 0._wp; d_cbL_${XYZ}$ (:,1) = d_cbL_${XYZ}$ (:,1)/sum(d_cbL_${XYZ}$ (:,1)) end if if (bc_s%end == BC_RIEMANN_EXTRAP) then - d_cbR_${XYZ}$ (0, s - 1) = 0._wp; d_cbR_${XYZ}$ (:, s - 1) = d_cbR_${XYZ}$ (:, & - & s - 1)/sum(d_cbR_${XYZ}$ (:, s - 1)) - d_cbL_${XYZ}$ (0, s - 1) = 0._wp; d_cbL_${XYZ}$ (:, s - 1) = d_cbL_${XYZ}$ (:, & - & s - 1)/sum(d_cbL_${XYZ}$ (:, s - 1)) - d_cbR_${XYZ}$ (0:1, s) = 0._wp; d_cbR_${XYZ}$ (2, s) = 1._wp - d_cbL_${XYZ}$ (0:1, s) = 0._wp; d_cbL_${XYZ}$ (2, s) = 1._wp + d_cbR_${XYZ}$ (0, s - 1) = 0._wp; d_cbR_${XYZ}$ (:,s - 1) = d_cbR_${XYZ}$ (:, & + & s - 1)/sum(d_cbR_${XYZ}$ (:,s - 1)) + d_cbL_${XYZ}$ (0, s - 1) = 0._wp; d_cbL_${XYZ}$ (:,s - 1) = d_cbL_${XYZ}$ (:, & + & s - 1)/sum(d_cbL_${XYZ}$ (:,s - 1)) + d_cbR_${XYZ}$ (0:1,s) = 0._wp; d_cbR_${XYZ}$ (2, s) = 1._wp + d_cbL_${XYZ}$ (0:1,s) = 0._wp; d_cbL_${XYZ}$ (2, s) = 1._wp end if end if else ! WENO7 @@ -861,13 +861,11 @@ contains & is2_weno_d, is3_weno_d) - type(scalar_field), dimension(1:), intent(in) :: v_vf - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, & - & vL_rs_vf_z - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vR_rs_vf_x, vR_rs_vf_y, & - & vR_rs_vf_z - integer, intent(in) :: weno_dir - type(int_bounds_info), intent(in) :: is1_weno_d, is2_weno_d, is3_weno_d + type(scalar_field), dimension(1:), intent(in) :: v_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vL_rs_vf_x, vL_rs_vf_y, vL_rs_vf_z + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vR_rs_vf_x, vR_rs_vf_y, vR_rs_vf_z + integer, intent(in) :: weno_dir + type(int_bounds_info), intent(in) :: is1_weno_d, is2_weno_d, is3_weno_d #:if not MFC_CASE_OPTIMIZATION and USING_AMD real(wp), dimension(-3:2) :: dvd @@ -884,7 +882,7 @@ contains real(wp), dimension(0:weno_num_stencils) :: beta real(wp), dimension(0:weno_num_stencils) :: delta #:endif - real(wp), dimension(-3:3) :: v ! temporary field value array for clarity (WENO7 only) + real(wp), dimension(-3:3) :: v !< temporary field value array for clarity (WENO7 only) real(wp) :: tau integer :: i, j, k, l, q @@ -975,7 +973,7 @@ contains & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils,j)))) else if (wenoz) then ! Borges, et al. (2008) @@ -1005,7 +1003,7 @@ contains & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils,j)))) else if (wenoz) then alpha(0:weno_num_stencils) = d_cbR_${XYZ}$ (0:weno_num_stencils, & & j)*(1._wp + tau/beta(0:weno_num_stencils)) @@ -1070,7 +1068,7 @@ contains & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils,j)))) else if (wenoz) then ! Borges, et al. (2008) @@ -1127,7 +1125,7 @@ contains & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils,j)))) else if (wenoz) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils @@ -1171,7 +1169,7 @@ contains delta(:) = 0._wp beta(:) = weno_eps - if (teno) v = v_rs_ws_${XYZ}$ (j - 3:j + 3, k, l, & + if (teno) v = v_rs_ws_${XYZ}$ (j - 3:j + 3,k, l, & & i) ! temporary field value array for clarity if (.not. teno) then @@ -1265,7 +1263,7 @@ contains & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & & *(omega(0:weno_num_stencils)/(d_cbL_${XYZ}$ (0:weno_num_stencils, & & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils, j)))) + & - 2._wp*d_cbL_${XYZ}$ (0:weno_num_stencils,j)))) else if (wenoz) then ! Castro, et al. (2010) Don & Borges (2013) also helps tau = abs(beta(3) - beta(0)) ! Equation 50 @@ -1340,7 +1338,7 @@ contains & j) - 3._wp*omega(0:weno_num_stencils)) + omega(0:weno_num_stencils)**2._wp) & & *(omega(0:weno_num_stencils)/(d_cbR_${XYZ}$ (0:weno_num_stencils, & & j)**2._wp + omega(0:weno_num_stencils)*(1._wp & - & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils, j)))) + & - 2._wp*d_cbR_${XYZ}$ (0:weno_num_stencils,j)))) else if (wenoz) then $:GPU_LOOP(parallelism='[seq]') do q = 0, weno_num_stencils @@ -1447,8 +1445,8 @@ contains !> Enforce monotonicity-preserving bounds on the WENO reconstruction subroutine s_preserve_monotonicity(v_rs_ws, vL_rs_vf, vR_rs_vf) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(in) :: v_rs_ws - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: vL_rs_vf, vR_rs_vf + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(in) :: v_rs_ws + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: vL_rs_vf, vR_rs_vf integer :: i, j, k, l real(wp), dimension(-1:1) :: d !< Curvature measures at the zone centers real(wp) :: d_MD, d_LC !< Median (md) curvature and large curvature (LC) measures